├── .gitignore
├── Dockerfile
├── LICENSE
├── Makefile
├── README.md
├── bin
├── client.py
└── client_curses.py
├── build.lisp
├── lisp-chat.asd
├── lisp-chat.png
├── logo
├── horizontal.png
├── logo.png
└── vertical.png
├── roswell
├── lisp-chat-server.ros
└── lisp-chat.ros
└── src
├── client.lisp
├── config.lisp
└── server.lisp
/.gitignore:
--------------------------------------------------------------------------------
1 | *.fasl
2 | *.FASL
3 | __pycache__
4 | system-index.txt
5 | lisp-chat
6 |
--------------------------------------------------------------------------------
/Dockerfile:
--------------------------------------------------------------------------------
1 | FROM commonlispbr/roswell:latest
2 | RUN apt update && apt install libreadline7 -y
3 | WORKDIR /lisp-chat
4 | COPY ./lisp-chat.asd lisp-chat.asd
5 | COPY ./src src
6 | COPY ./roswell roswell
7 | RUN ros install ./
8 | EXPOSE 5558
9 | ENTRYPOINT ["/root/.roswell/bin/lisp-chat-server"]
10 |
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 |
2 | The MIT License (MIT)
3 |
4 | Copyright (c) 2017 Manoel Vilela
5 |
6 | Permission is hereby granted, free of charge, to any person obtaining a copy
7 | of this software and associated documentation files (the "Software"), to deal
8 | in the Software without restriction, including without limitation the rights
9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
10 | copies of the Software, and to permit persons to whom the Software is
11 | furnished to do so, subject to the following conditions:
12 |
13 | The above copyright notice and this permission notice shall be included in all
14 | copies or substantial portions of the Software.
15 |
16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
19 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
21 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
22 | SOFTWARE.
--------------------------------------------------------------------------------
/Makefile:
--------------------------------------------------------------------------------
1 | SBCL_CMD := sbcl --noinform --disable-debugger --load
2 | OBJECTS := lisp-inference
3 |
4 |
5 | all: $(OBJECTS)
6 |
7 |
8 | $(OBJECTS): src/*.lisp
9 | $(SBCL_CMD) build.lisp
10 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 |
2 | 
3 |
4 |
5 |
6 | [](http://quickdocs.org/lisp-chat/)
7 |
8 | # Lisp Chat
9 |
10 | An experimental chat irc-like written in Lisp.
11 |
12 | 
13 |
14 |
15 | # Installation
16 | Install [roswell][ros] and add `~/.roswell/bin/` to the `PATH` variable.
17 |
18 | After that just type:
19 |
20 | ``` bash
21 | ros install ryukinix/lisp-chat
22 | ```
23 |
24 | Lisp-chat it's on Quicklisp as well, tested on the following
25 | implementations:
26 |
27 | * SBCL
28 | * CCL
29 | * ECL
30 |
31 | # Usage
32 |
33 |
34 | Load the server
35 | ```bash
36 | $ lisp-chat-server localhost
37 | ```
38 |
39 | Create a client
40 | ```bash
41 | $ lisp-chat localhost
42 | ```
43 |
44 | As alternative of `localhost` you can use `server.lerax.me` which
45 | points to a lisp-chat server running in the port 5558.
46 |
47 |
48 |
49 | # Alternative clients
50 |
51 | If you want test this and don't have the Lisp requested, I have those
52 | alternatives for you:
53 |
54 | * Terminal text-based python client
55 | * Terminal ncurses python client
56 | * Netcat client (wtf?)
57 |
58 | On Python client, I wrote in a way only using ths stdlib avoiding pain
59 | to handle the dependency hell, so you can just call that:
60 |
61 | ```bash
62 | $ python client.py
63 | ```
64 |
65 | So finally... netcat. Yes! You can even just use `netcat`! An user
66 | called `Chris` in past days just logged in the server with the
67 | following message:
68 |
69 | ```
70 | |16:30:37| [Chris]: Used netcad
71 | |16:30:41| [Chris]: netcat*
72 | |16:30:50| [Chris]: bye
73 | ```
74 |
75 | So you can type `netcat server.lerax.me 5558` and go on! I tested on
76 | my machine and works fine! The main reason is because the
77 | communication between server and client just use raw data. For better
78 | synchronization with text data from server while you typing, I suggest
79 | you to use a readline wrapper like
80 | [`rlwrap`](https://github.com/hanslub42/rlwrap) calling as `rlwrap
81 | netcat server.lerax.me 5558`.
82 |
83 |
84 |
85 | 
86 |
87 |
88 |
--------------------------------------------------------------------------------
/bin/client.py:
--------------------------------------------------------------------------------
1 | #!/usr/bin/env python
2 | # Author: Manoel Vilela
3 |
4 | import socket
5 | import threading
6 | import readline
7 |
8 | HOST = 'chat.lerax.me'
9 | PORT = 5558
10 |
11 | # set editing-mode on input
12 | readline.parse_and_bind('set editing-mode vi')
13 |
14 | s = socket.socket()
15 | s.connect((HOST, PORT))
16 | read_stream = s.makefile()
17 | write_stream = s.makefile(mode='w')
18 |
19 |
20 | def get_user_input():
21 | inp = input()
22 | print("\033[1A\033[2K", end='')
23 | return inp
24 |
25 |
26 | def server_reader():
27 | """Fetch lines from server and print"""
28 | try:
29 | while not read_stream.closed:
30 | print(read_stream.readline(), end='')
31 | except ValueError:
32 | pass
33 | # after the read_stream is closed, in the case
34 | # the thread is running read_stream.readline()
35 | # is running this will throw a exception of
36 | # IO operation on closed file.
37 |
38 |
39 | def send_message(message):
40 | write_stream.write(message + '\n')
41 | write_stream.flush()
42 |
43 |
44 | def main():
45 | try:
46 | username = input(str(read_stream.readline().strip('\n')))
47 | print("Connected as {}@{}:{}".format(username, HOST, PORT))
48 | send_message(username)
49 | inp = ""
50 | t = threading.Thread(target=server_reader)
51 | t.start()
52 | while inp != "/quit":
53 | inp = get_user_input()
54 | send_message(inp)
55 | except KeyboardInterrupt:
56 | send_message("/quit")
57 | finally:
58 | read_stream.close()
59 | write_stream.close()
60 | s.close()
61 | t.join()
62 |
63 |
64 | if __name__ == '__main__':
65 | main()
66 |
--------------------------------------------------------------------------------
/bin/client_curses.py:
--------------------------------------------------------------------------------
1 | #!/usr/bin/env python
2 | # Author: Manoel Vilela
3 |
4 | import curses
5 | import socket
6 | import threading
7 |
8 | HOST = 'chat.lerax.me'
9 | PORT = 5558
10 |
11 | s = socket.socket()
12 | s.connect((HOST, PORT))
13 | read_stream = s.makefile()
14 | write_stream = s.makefile(mode='w')
15 |
16 |
17 | class ChatUI(object):
18 | def __init__(self, stdscr):
19 | curses.use_default_colors()
20 | for i in range(0, curses.COLORS):
21 | curses.init_pair(i, i, -1)
22 | self.stdscr = stdscr
23 | self.inputbuffer = ""
24 | self.linebuffer = []
25 | self.chatbuffer = []
26 |
27 | # Curses, why must you confuse me with your height, width, y, x
28 | chatbuffer_hwyx = (curses.LINES - 2, curses.COLS-1, 0, 1)
29 | chatline_yx = (curses.LINES - 1, 0)
30 | self.win_chatline = stdscr.derwin(*chatline_yx)
31 | self.win_chatbuffer = stdscr.derwin(*chatbuffer_hwyx)
32 | self.redraw_ui()
33 |
34 | def resize(self):
35 | """Handles a change in terminal size"""
36 | h, w = self.stdscr.getmaxyx()
37 |
38 | self.win_chatline.mvwin(h - 1, 0)
39 | self.win_chatline.resize(1, w)
40 | self.win_chatbuffer.resize(h - 2, w - 2)
41 |
42 | self.linebuffer = []
43 | for msg in self.chatbuffer:
44 | self._linebuffer_add(msg)
45 |
46 | self.redraw_ui()
47 |
48 | def redraw_ui(self):
49 | """Redraws the entire UI"""
50 | h, w = self.stdscr.getmaxyx()
51 | self.stdscr.clear()
52 | self.stdscr.vline(0, 1, "|", h - 2)
53 | self.stdscr.hline(h - 2, 0, "-", w)
54 | self.stdscr.refresh()
55 |
56 | self.redraw_chatbuffer()
57 | self.redraw_chatline()
58 |
59 | def redraw_chatline(self):
60 | """Redraw the user input textbox"""
61 | h, w = self.win_chatline.getmaxyx()
62 | self.win_chatline.clear()
63 | start = len(self.inputbuffer) - w + 1
64 | if start < 0:
65 | start = 0
66 | self.win_chatline.addstr(0, 0, self.inputbuffer[start:])
67 | self.win_chatline.refresh()
68 |
69 | def redraw_chatbuffer(self):
70 | """Redraw the chat message buffer"""
71 | self.win_chatbuffer.clear()
72 | h, w = self.win_chatbuffer.getmaxyx()
73 | j = len(self.linebuffer) - h
74 | if j < 0:
75 | j = 0
76 | for i in range(min(h, len(self.linebuffer))):
77 | self.win_chatbuffer.insstr(i, 0, self.linebuffer[j])
78 | j += 1
79 | self.win_chatbuffer.refresh()
80 |
81 | def chatbuffer_add(self, msg):
82 | """Add a message to the chat buffer, automatically slicing it to
83 | fit the width of the buffer
84 | """
85 | self.chatbuffer.append(msg)
86 | self._linebuffer_add(msg)
87 | self.redraw_chatbuffer()
88 | self.redraw_chatline()
89 | self.win_chatline.cursyncup()
90 |
91 | def _linebuffer_add(self, msg):
92 | h, w = self.stdscr.getmaxyx()
93 | w = w - 2
94 | while len(msg) >= w:
95 | self.linebuffer.append(msg[:w])
96 | msg = msg[w:]
97 | if msg:
98 | self.linebuffer.append(msg)
99 |
100 | def prompt(self, msg):
101 | """Prompts the user for input and returns it"""
102 | self.inputbuffer = msg
103 | self.redraw_chatline()
104 | res = self.wait_input()
105 | res = res[len(msg):]
106 | return res
107 |
108 | def wait_input(self, prompt=""):
109 | """Wait for the user to input a message and hit enter.
110 | Returns the message
111 | """
112 | self.inputbuffer = prompt
113 | self.redraw_chatline()
114 | self.win_chatline.cursyncup()
115 | last = -1
116 | while last != ord('\n'):
117 | last = self.stdscr.getch()
118 | if last == ord('\n'):
119 | tmp = self.inputbuffer
120 | self.inputbuffer = ""
121 | self.redraw_chatline()
122 | self.win_chatline.cursyncup()
123 | return tmp[len(prompt):]
124 | elif last == curses.KEY_BACKSPACE or last == 127:
125 | if len(self.inputbuffer) > len(prompt):
126 | self.inputbuffer = self.inputbuffer[:-1]
127 | elif last == curses.KEY_RESIZE:
128 | self.resize()
129 | elif 32 <= last <= 126:
130 | self.inputbuffer += chr(last)
131 | self.redraw_chatline()
132 |
133 |
134 | def writer():
135 | """Fetch lines from server and fill the chatbuffer"""
136 | global chat
137 | while not read_stream.closed:
138 | chat.chatbuffer_add(read_stream.readline())
139 |
140 |
141 | def main(stdscr):
142 | """Main routine to be wrapped on curses.wrapper"""
143 | global chat
144 | stdscr.clear()
145 | chat = ChatUI(stdscr)
146 | try:
147 | username = chat.wait_input(str(read_stream.readline().strip('\n')))
148 | write_stream.write(username + '\n')
149 | write_stream.flush()
150 | inp = ""
151 | t = threading.Thread(target=writer)
152 | t.start()
153 | while inp != "/quit":
154 | inp = chat.wait_input()
155 | write_stream.write(inp + '\n')
156 | write_stream.flush()
157 | except KeyboardInterrupt:
158 | pass
159 | finally:
160 | read_stream.close()
161 | write_stream.close()
162 | s.close()
163 | t.join()
164 |
165 |
166 | curses.wrapper(main)
167 |
--------------------------------------------------------------------------------
/build.lisp:
--------------------------------------------------------------------------------
1 | (defparameter *compression* 9 "Compression level of the executable binary.")
2 | (defparameter *debug* nil "Debug information")
3 |
4 | (eval-when (:execute)
5 | (pushnew (truename (sb-unix:posix-getcwd/)) ql:*local-project-directories*)
6 | (ql:register-local-projects)
7 | (ql:quickload '(:lisp-chat :cffi)))
8 |
9 | (defmacro debug-format (&rest body)
10 | (when *debug*
11 | `(format t ,@body)))
12 |
13 | (defun import-foreign-libraries ()
14 | (let ((libpath (uiop/os:getcwd)))
15 | (debug-format "=> New LD_LIBRARY_PATH: ~a~%" libpath)
16 | (pushnew libpath
17 | cffi:*foreign-library-directories*
18 | :test #'equal)
19 | (cffi:define-foreign-library libreadline
20 | (t "libreadline.so"))
21 | (cffi:use-foreign-library libreadline))
22 | (debug-format "Loaded libraries: ~a~%" (cffi:list-foreign-libraries)))
23 |
24 |
25 | (defun main()
26 | (import-foreign-libraries)
27 | (lisp-chat/client:main))
28 |
29 |
30 | (eval-when (:execute)
31 | ;; close currently foreign libraries loaded
32 | (loop for library in (cffi:list-foreign-libraries :loaded-only t)
33 | do (cffi:close-foreign-library library))
34 | (sb-ext:save-lisp-and-die "lisp-chat"
35 | :toplevel #'main
36 | :executable t
37 | :compression *compression*))
38 |
--------------------------------------------------------------------------------
/lisp-chat.asd:
--------------------------------------------------------------------------------
1 | ;; Common Lisp Script
2 | ;; Manoel Vilela
3 |
4 |
5 | (asdf/defsystem:defsystem :lisp-chat/server
6 | :author "Manoel Vilela"
7 | :description "An experimental chat irc-like: server"
8 | :version "0.2.0"
9 | :mailto "manoel_vilela@engineer.com"
10 | :license "MIT"
11 | :depends-on ("usocket"
12 | "bordeaux-threads")
13 | :pathname "src"
14 | :components ((:file "config")
15 | (:file "server" :depends-on ("config"))))
16 |
17 | (asdf/defsystem:defsystem :lisp-chat/client
18 | :author "Manoel Vilela"
19 | :description "An experimental chat irc-like: client"
20 | :version "0.2.0"
21 | :license "MIT"
22 | :depends-on ("usocket"
23 | "cl-readline"
24 | "bordeaux-threads")
25 | :pathname "src"
26 | :components ((:file "config")
27 | (:file "client" :depends-on ("config"))))
28 |
29 | (asdf/defsystem:defsystem :lisp-chat
30 | :author "Manoel Vilela"
31 | :description "An experimental chat irc-like"
32 | :version "0.2.0"
33 | :license "MIT"
34 | :depends-on ("lisp-chat/client"
35 | "lisp-chat/server"))
36 |
--------------------------------------------------------------------------------
/lisp-chat.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/ryukinix/lisp-chat/c60dea5e94acb2ae0858587204e77aa0a9ad486b/lisp-chat.png
--------------------------------------------------------------------------------
/logo/horizontal.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/ryukinix/lisp-chat/c60dea5e94acb2ae0858587204e77aa0a9ad486b/logo/horizontal.png
--------------------------------------------------------------------------------
/logo/logo.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/ryukinix/lisp-chat/c60dea5e94acb2ae0858587204e77aa0a9ad486b/logo/logo.png
--------------------------------------------------------------------------------
/logo/vertical.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/ryukinix/lisp-chat/c60dea5e94acb2ae0858587204e77aa0a9ad486b/logo/vertical.png
--------------------------------------------------------------------------------
/roswell/lisp-chat-server.ros:
--------------------------------------------------------------------------------
1 | #!/bin/sh
2 | #|-*- mode:lisp -*-|#
3 | #|
4 | exec ros -Q -- $0 "$@"
5 | |#
6 | (progn ;;init forms
7 | (ros:ensure-asdf)
8 | #+quicklisp(ql:quickload '(:lisp-chat/server) :silent t))
9 |
10 | (defpackage :ros.script.lisp-chat-server
11 | (:use :cl))
12 | (in-package :ros.script.lisp-chat-server)
13 |
14 |
15 | (defparameter *usage*
16 | (format nil
17 | "usage: lisp-chat-server [-h|--help] [host] [port]
18 |
19 | OPTIONS
20 | host server host, default: ~a
21 | port server port, default: ~a
22 | -h | --help show this message
23 | " lisp-chat/config:*host*
24 | lisp-chat/config:*port*))
25 |
26 | (defun help (argv)
27 | (when (loop for arg in argv
28 | thereis (or (equal arg "-h")
29 | (equal arg "--help")))
30 | (princ *usage*)))
31 |
32 | (defun main (&rest argv)
33 | (declare (ignorable argv))
34 |
35 | (let ((host (car argv))
36 | (port (cadr argv)))
37 | (when host
38 | (setq lisp-chat/config:*host* host))
39 | (when port
40 | (setq lisp-chat/config:*port* (parse-integer port))))
41 |
42 | (unless (help argv)
43 | (lisp-chat/server:main :host lisp-chat/config:*host*
44 | :port lisp-chat/config:*port*)))
45 | ;;; vim: set ft=lisp lisp:
46 |
--------------------------------------------------------------------------------
/roswell/lisp-chat.ros:
--------------------------------------------------------------------------------
1 | #!/bin/sh
2 | #|-*- mode:lisp -*-|#
3 | #|
4 | exec ros -Q -- $0 "$@"
5 | |#
6 | (progn ;;init forms
7 | (ros:ensure-asdf)
8 | #+quicklisp (ql:quickload '(lisp-chat/client) :silent t))
9 |
10 | (defpackage :ros.script.lisp-chat
11 | (:use :cl))
12 | (in-package :ros.script.lisp-chat)
13 |
14 | (defparameter *usage*
15 | (format nil
16 | "usage: lisp-chat [-h|--help] [host] [port]
17 |
18 | OPTIONS
19 | host server host, default: ~a
20 | port server port, default: ~a
21 | -h | --help show this message
22 | " lisp-chat/config:*host*
23 | lisp-chat/config:*port*))
24 |
25 | (defun help (argv)
26 | (when (loop for arg in argv
27 | thereis (or (equal arg "-h")
28 | (equal arg "--help")))
29 | (princ *usage*)))
30 |
31 |
32 | (defun main (&rest argv)
33 | (declare (ignorable argv))
34 |
35 | (let ((host (car argv))
36 | (port (cadr argv)))
37 | (when host
38 | (setq lisp-chat/config:*host* host))
39 | (when port
40 | (setq lisp-chat/config:*port* (parse-integer port))))
41 |
42 | (unless (help argv)
43 | (lisp-chat/client:main :host lisp-chat/config:*host*
44 | :port lisp-chat/config:*port*)))
45 | ;;; vim: set ft=lisp lisp:
46 |
--------------------------------------------------------------------------------
/src/client.lisp:
--------------------------------------------------------------------------------
1 | ;; Common Lisp Script
2 | ;; Manoel Vilela
3 |
4 | (defpackage :lisp-chat/client
5 | (:use #:usocket
6 | #:cl
7 | #:lisp-chat/config
8 | #:bordeaux-threads)
9 | (:export :main))
10 |
11 | (in-package :lisp-chat/client)
12 |
13 | (defvar *io-lock* (make-lock "io mutex")
14 | "I/O Mutex for avoid terminal race conditions")
15 |
16 | (defun erase-last-line ()
17 | "Erase the last line by using ANSI Escape codes"
18 | (format t "~C[1A~C[2K" #\Esc #\Esc))
19 |
20 |
21 | (defun get-user-input (username)
22 | "Get the user input by using readline"
23 | (prog1 (cl-readline:readline :prompt (format nil "[~A]: " username)
24 | :erase-empty-line t
25 | :add-history t)
26 | (with-lock-held (*io-lock*)
27 | (erase-last-line))))
28 |
29 |
30 | (defun send-message (message socket)
31 | "Send a MESSAGE string through a SOCKET instance"
32 | (write-line message (socket-stream socket))
33 | (finish-output (socket-stream socket)))
34 |
35 | ;; HACK: I don't know a better way to save state of cl-readline
36 | ;; before printing messages from server, so I'm cleaning all the stuff
37 | ;; before print a new message, and restore again. Maybe there is a
38 | ;; better way for doing that.
39 | (defun receive-message (message)
40 | "Receive a message and print in the terminal carefully with IO race conditions"
41 | (with-lock-held (*io-lock*)
42 | (let ((line cl-readline:*line-buffer*)
43 | (prompt cl-readline:+prompt+))
44 | ;; erase
45 | (cl-readline:replace-line "" nil)
46 | (cl-readline:set-prompt "")
47 | (cl-readline:redisplay)
48 | ;; print message from server
49 | (write-line message)
50 | ;; restore
51 | (cl-readline:replace-line (or line "") nil)
52 | (setq cl-readline:*point* cl-readline:+end+)
53 | (cl-readline:set-prompt prompt)
54 | (cl-readline:redisplay))))
55 |
56 | (defun client-sender (socket username)
57 | "Routine to check new messages being typed by the user"
58 | (loop for message = (get-user-input username)
59 | when (or (equal message "/quit")
60 | (equal message nil))
61 | return nil
62 | do (send-message message socket))
63 | (uiop:quit))
64 |
65 |
66 | (defun server-listener (socket)
67 | "Routine to check new messages coming from the server"
68 | (loop for message = (read-line (socket-stream socket))
69 | while (not (equal message "/quit"))
70 | do (receive-message message)))
71 |
72 | (defun server-broadcast (socket)
73 | "Call server-listener treating exceptional cases"
74 | (handler-case (server-listener socket)
75 | (end-of-file (e)
76 | (format t "~%End of connection: ~a~%" e)
77 | (uiop:quit 1))
78 | (simple-error ()
79 | (server-broadcast socket))))
80 |
81 |
82 | (defun login (socket)
83 | "Do the login of the application given a SOCKET instances"
84 | (princ (read-line (socket-stream socket)))
85 | (finish-output)
86 | (let ((username (read-line)))
87 | (send-message username socket)
88 | username))
89 |
90 |
91 | (defun client-loop (host port)
92 | "Dispatch client threads for basic functioning system"
93 | (let* ((socket (socket-connect host port))
94 | (username (login socket)))
95 | (format t "Connected as ~a\@~a\:~a ~%" username *host* *port*)
96 | (let ((sender (make-thread (lambda () (client-sender socket username))
97 | :name "client sender"))
98 | (broadcast (make-thread (lambda () (server-broadcast socket))
99 | :name "server broadcast")))
100 | (join-thread sender)
101 | (join-thread broadcast))))
102 |
103 | (defun main (&key (host *host*) (port *port*))
104 | "Main function of client"
105 | (handler-case (client-loop host port)
106 | (#+sbcl sb-sys:interactive-interrupt
107 | #+ccl ccl:interrupt-signal-condition
108 | #+clisp system::simple-interrupt-condition
109 | #+ecl ext:interactive-interrupt
110 | #+allegro excl:interrupt-signal ()
111 | (uiop:quit 0))
112 | (usocket:connection-refused-error ()
113 | (progn (write-line "Server seems offline. Run first the server.lisp.")
114 | (uiop:quit 1)))))
115 |
--------------------------------------------------------------------------------
/src/config.lisp:
--------------------------------------------------------------------------------
1 | ;; Common Lisp Script
2 | ;; Manoel Vilela
3 |
4 | (defpackage :lisp-chat/config
5 | (:use :cl)
6 | (:export :*debug*
7 | :*host*
8 | :*port*))
9 |
10 | (in-package :lisp-chat/config)
11 |
12 | (defparameter *debug* t "Run application in debug mode with extra info in terminal")
13 | (defparameter *host* "localhost" "Host used in server and client")
14 | (defparameter *port* 5558 "Default port")
15 |
--------------------------------------------------------------------------------
/src/server.lisp:
--------------------------------------------------------------------------------
1 | ;; Common Lisp Script
2 | ;; Manoel Vilela
3 |
4 | (defpackage #:lisp-chat/server
5 | (:use #:usocket
6 | #:cl
7 | #:lisp-chat/config
8 | #:bordeaux-threads)
9 | (:export #:main))
10 |
11 | (in-package :lisp-chat/server)
12 |
13 |
14 | ;; global vars
15 | (defvar *day-names* '("Monday" "Tuesday" "Wednesday"
16 | "Thursday" "Friday" "Saturday" "Sunday")
17 | "Day names")
18 | (defvar *uptime* (multiple-value-list (get-decoded-time))
19 | "Uptime of server variable")
20 | (defparameter *commands-names*
21 | '("/users" "/help" "/log" "/quit" "/uptime" "/nick")
22 | "Allowed command names to be called by client user")
23 | (defparameter *clients* nil "List of clients")
24 | (defparameter *messages-stack* nil "Messages pending to be send by broadcasting")
25 | (defparameter *messages-log* nil "Messages log")
26 | (defparameter *server-nickname* "@server" "The server nickname")
27 |
28 |
29 | ;; thread control
30 | (defvar *message-semaphore* (make-semaphore :name "message semaphore"
31 | :count 0))
32 | (defvar *client-lock* (make-lock "client list lock"))
33 |
34 |
35 |
36 | (defstruct message
37 | "This structure abstract the type message with is saved
38 | into *messages-log* and until consumed, temporally pushed
39 | to *messages-stack*. FROM, CONTENT and TIME has type string"
40 | from
41 | content
42 | time )
43 |
44 | (defstruct client
45 | "This structure handle the creation/control of the clients of the server.
46 | NAME is a string. Socket is a USOCKET:SOCKET and address is a ipv4 encoded
47 | string. "
48 | name
49 | socket
50 | address)
51 |
52 |
53 | (defun socket-peer-address (socket)
54 | "Given a USOCKET:SOCKET instance return a ipv4 encoded IP string"
55 | (format nil "~{~a~^.~}\:~a"
56 | (map 'list #'identity (get-peer-address socket))
57 | (get-peer-port socket)))
58 |
59 | (defun client-stream (c)
60 | "Select the stream IO from the client"
61 | (socket-stream (client-socket c)))
62 |
63 |
64 | (defun debug-format (&rest args)
65 | "If *debug* from lisp-chat-config is true, print debug info on
66 | running based on ARGS"
67 | (if *debug*
68 | (apply #'format args)))
69 |
70 |
71 | (defun get-time ()
72 | "Return a encoded string as HH:MM:SS based on the current timestamp."
73 | (multiple-value-bind (second minute hour)
74 | (get-decoded-time)
75 | (format nil "~2,'0d:~2,'0d:~2,'0d" hour minute second)))
76 |
77 |
78 | (defun formated-message (message)
79 | "The default message format of this server. MESSAGE is a string
80 | Changing this reflects all the layout from client/server.
81 | Probably this would be the MFRP: Manoel Fucking Raw Protocol.
82 | Because this we can still use netcat as client for lisp-chat."
83 | (format nil "|~a| [~a]: ~a"
84 | (message-time message)
85 | (message-from message)
86 | (message-content message)))
87 |
88 | (defun command-message (content)
89 | "This function prepare the CONTENT as a message by the @server"
90 | (let* ((from *server-nickname*)
91 | (time (get-time))
92 | (message (make-message :from from :content content :time time)))
93 | (formated-message message)))
94 |
95 | (defun call-command-by-name (string params)
96 | "Wow, this is a horrible hack to get a string as symbol for functions/command
97 | like /help /users /log and so on."
98 | (let ((command-function (find-symbol (string-upcase string) :lisp-chat/server)))
99 | (when command-function
100 | (apply command-function params))))
101 |
102 | ;; user commands prefixed with /
103 | (defun /users (client &rest args)
104 | "Return a list separated by commas of the currently logged users"
105 | (declare (ignorable client args))
106 | (command-message (format nil "~{~a~^, ~}" (mapcar #'client-name *clients*))))
107 |
108 |
109 | (defun /help (client &rest args)
110 | "Show a list of the available commands of lisp-chat"
111 | (declare (ignorable client args))
112 | (command-message (format nil "~{~a~^, ~}" *commands-names*)))
113 |
114 |
115 | (defun /log (client &optional (depth "20") &rest args)
116 | "Show the last messages typed on the server.
117 | DEPTH is optional number of messages frames from log"
118 | (declare (ignorable client args))
119 | (let ((messages (min (or (parse-integer depth :junk-allowed t) 20)
120 | (length *messages-log*))))
121 | (format nil "~{~a~^~%~}" (reverse (subseq *messages-log* 0
122 | messages)))))
123 |
124 | (defun /uptime (client &rest args)
125 | "Return a string nice encoded to preset the uptime since the server started."
126 | (declare (ignorable client args))
127 | (multiple-value-bind
128 | (second minute hour date month year day-of-week dst-p tz)
129 | (values-list *uptime*)
130 | (declare (ignore dst-p))
131 | (command-message
132 | (format nil
133 | "Server online since ~2,'0d:~2,'0d:~2,'0d of ~a, ~2,'0d/~2,'0d/~d (GMT~@d)"
134 | hour minute second
135 | (nth day-of-week *day-names*)
136 | month date year
137 | (- tz)))))
138 |
139 | (defun /nick (client &optional (new-nick nil) &rest args)
140 | "Change the client-name given a NEW-NICK which should be a string"
141 | (declare (ignorable args))
142 | (if new-nick
143 | (progn (setf (client-name client) new-nick)
144 | (command-message (format nil "Your new nick is: ~a" new-nick)))
145 | (command-message (format nil "/nick "))))
146 |
147 |
148 | (defun push-message (from content)
149 | "Push a messaged FROM as CONTENT into the *messages-stack*"
150 | (push (make-message :from from
151 | :content content
152 | :time (get-time))
153 | *messages-stack*)
154 | (signal-semaphore *message-semaphore*))
155 |
156 | (defun client-delete (client)
157 | "Delete a CLIENT from the list *clients*"
158 | (with-lock-held (*client-lock*)
159 | (setf *clients* (remove-if (lambda (c)
160 | (equal (client-address c)
161 | (client-address client)))
162 | *clients*)))
163 | (push-message "@server" (format nil "The user ~s exited from the party :("
164 | (client-name client)))
165 | (debug-format t "Deleted user ~a@~a~%"
166 | (client-name client)
167 | (client-address client))
168 | (socket-close (client-socket client)))
169 |
170 | (defun send-message (client message)
171 | "Send to CLIENT a MESSAGE :type string"
172 | (let ((stream (client-stream client)))
173 | (write-line message stream)
174 | (finish-output stream)))
175 |
176 | (defun startswith (string substring)
177 | "Check if STRING starts with SUBSTRING."
178 | (let ((l1 (length string))
179 | (l2 (length substring)))
180 | (when (and (> l2 0)
181 | (>= l1 l2))
182 | (loop for c1 across string
183 | for c2 across substring
184 | always (equal c1 c2)))))
185 |
186 | (defun split (string delimiterp)
187 | "Split a string by a delimiterp function character checking"
188 | (loop for beg = (position-if-not delimiterp string)
189 | then (position-if-not delimiterp string :start (1+ end))
190 | for end = (and beg (position-if delimiterp string :start beg))
191 | when beg
192 | collect (subseq string beg end)
193 | while end))
194 |
195 | (defun extract-params (string)
196 | (subseq (split string (lambda (c) (eql c #\Space)))
197 | 1))
198 |
199 | (defun call-command (client message)
200 | (let ((command (find message *commands-names* :test #'startswith)))
201 | (when command
202 | (call-command-by-name command (cons client
203 | (extract-params message))))))
204 |
205 | (defun client-reader-routine (client)
206 | "This function create a IO-bound procedure to act
207 | by reading the events of a specific CLIENT.
208 | On this software each client talks on your own thread."
209 | (loop for message := (read-line (client-stream client))
210 | while (not (equal message "/quit"))
211 | for response := (call-command client message)
212 | if response
213 | do (send-message client response)
214 | else
215 | when (> (length message) 0)
216 | do (push-message (client-name client)
217 | message)
218 | finally (client-delete client)))
219 |
220 | (defun client-reader (client)
221 | "This procedure is a wrapper for CLIENT-READER-ROUTINE
222 | treating all the possible errors based on HANDLER-CASE macro."
223 | (handler-case (client-reader-routine client)
224 | (end-of-file () (client-delete client))
225 | (#+sbcl sb-int:simple-stream-error
226 | #-sbcl error
227 | ()
228 | (progn (debug-format t "~a@~a timed output"
229 | (client-name client)
230 | (client-address client))
231 | (client-delete client)))
232 | (#+sbcl sb-bsd-sockets:not-connected-error
233 | #-sbcl error
234 | ()
235 | (progn (debug-format t "~a@~a not connected more."
236 | (client-name client)
237 | (client-address client))
238 | (client-delete client)))))
239 |
240 | (defun create-client (connection)
241 | "This procedure create a new client based on CONNECTION made by
242 | USOCKET:SOCKET-ACCEPT. This shit create a lot of side effects as messages
243 | if the debug is on because this makes all the log stuff to make analysis"
244 | (debug-format t "Incoming connection from ~a ~%" (socket-peer-address connection))
245 | (let ((client-stream (socket-stream connection)))
246 | (write-line "> Type your username: " client-stream)
247 | (finish-output client-stream)
248 | (let ((client (make-client :name (read-line client-stream)
249 | :socket connection
250 | :address (socket-peer-address connection))))
251 | (with-lock-held (*client-lock*)
252 | (debug-format t "Added new user ~a@~a ~%"
253 | (client-name client)
254 | (client-address client))
255 | (push client *clients*))
256 | (push-message "@server" (format nil "The user ~s joined to the party!" (client-name client)))
257 | (make-thread (lambda () (client-reader client))
258 | :name (format nil "~a reader thread" (client-name client))))))
259 |
260 | ;; a function defined to handle the errors of client thread
261 | (defun safe-client-thread (connection)
262 | "This function is a wrapper for CREATE-CLIENT treating the
263 | exceptions."
264 | (handler-case (create-client connection)
265 | (end-of-file () nil)
266 | (usocket:address-in-use-error () nil)))
267 |
268 | (defun message-broadcast ()
269 | "This procedure is a general independent thread to run brodcasting
270 | all the clients when a message is ping on this server"
271 | (loop when (wait-on-semaphore *message-semaphore*)
272 | do (let ((message (formated-message (pop *messages-stack*))))
273 | (push message *messages-log*)
274 | (loop for client in *clients*
275 | do (handler-case (send-message client message)
276 | (#+sbcl sb-int:simple-stream-error
277 | #-sbcl error ()
278 | (client-delete client))
279 | (#+sbcl sb-bsd-sockets:not-connected-error
280 | #-sbcl error ()
281 | (client-delete client)))))))
282 |
283 | (defun connection-handler (socket-server)
284 | "This is a special thread just for accepting connections from SOCKET-SERVER
285 | and creating new clients from it."
286 | (loop for connection = (socket-accept socket-server)
287 | do (make-thread (lambda () (safe-client-thread connection))
288 | :name "create client")))
289 |
290 | (defun server-loop (socket-server)
291 | "This is the general server-loop procedure. Create the threads
292 | necessary for the basic working state of this chat. The main idea
293 | is creating a MESSAGE-BROADCAST procedure and CONNECTION-HANDLER
294 | procedure running as separated threads.
295 |
296 | The first procedure send always a new message too all clients
297 | defined on *clients* when *messages-semaphore* is signalized.
298 | The second procedure is a general connection-handler for new
299 | clients trying connecting to the server."
300 | (format t "Running server at ~a:~a... ~%" *host* *port*)
301 | (let* ((connection-thread (make-thread (lambda () (connection-handler socket-server))
302 | :name "Connection handler"))
303 | (broadcast-thread (make-thread #'message-broadcast
304 | :name "Message broadcast")))
305 | (join-thread connection-thread)
306 | (join-thread broadcast-thread)))
307 |
308 | (defun main (&key (host *host*) (port *port*))
309 | "Well, this function run all the necessary shits."
310 | (let ((socket-server nil)
311 | (error-code 0))
312 | (unwind-protect
313 | (handler-case
314 | (progn (setq socket-server (socket-listen host port))
315 | (server-loop socket-server))
316 | (usocket:address-in-use-error ()
317 | (format *error-output*
318 | "error: Address:port at ~a\:~a already busy.~%"
319 | *host*
320 | *port*)
321 | (setq error-code 1))
322 | (usocket:address-not-available-error ()
323 | (format *error-output*
324 | "error: There is no way to use ~a as host to run the server.~%"
325 | *host*)
326 | (setq error-code 2))
327 | (#+sbcl sb-sys:interactive-interrupt
328 | #+ccl ccl:interrupt-signal-condition
329 | #+clisp system::simple-interrupt-condition
330 | #+ecl ext:interactive-interrupt
331 | #+allegro excl:interrupt-signal ()
332 | (format t "~%Closing the server...~%")))
333 | (when socket-server
334 | (socket-close socket-server))
335 | (uiop:quit error-code))))
336 |
--------------------------------------------------------------------------------