#!/usr/bin/newlisp
#
# Simple newlisp CHAT program - using UDP protocol.
#
# September 4 2004 - January 2 2005 by peter@gtk-server.org
# Adapted for GTK-server 1.2 at October 9, 2004 by PvE
# Adapted for GTK-server 1.3 at December 9, 2004 by PvE
# Adapted to GTK-server 2.0.6 and higher at January 20, 2006
# Adapted for newLisp 10 at December 28, 2008 - PvE.
#
# Requirements:	newLisp 10 or higher
#		GTK-server 2.0 build 6 or higher
#		Linux, Windows2000/XP, MacOSX
#
# Features:	- Full GTK2.x							(1.0)
#		- Using scrolled text_view widget				(1.0)
#		- Memorizes last entered configuration				(1.0)
#		- Works on Linux and Win32 with same source code		(1.0)	    
#		- Uses encryption of the actual chat				(1.0)
#		---------------------------------------------------------
#		- Uses extended formatting features of text_view		(1.1)
#		- Able to have UDP or MultiCast communication			(1.1)
#		- Notification if frame is lost (UDP mode)			(1.1)
#		- Communication with GTK-server is UDP also			(1.1)
#		- Fixed bug with encryption string				(1.1)
#		- Fixed bug with inserting text					(1.1)
#		- Fixed bug with getting time on Linux				(1.1)
#		- Fixed bug with sending empty strings				(1.1)
#		---------------------------------------------------------
#		- Solved issue with closing bracket ')'	in chattext		(1.1b)
#		---------------------------------------------------------
#		- Redesigned mainloop for GTK-server 1.2			(1.2)
#		- Code optimizations						(1.2)
#		---------------------------------------------------------
#		- Changed to STDIN communication interface			(1.3)
#		- Fixed bug with adding IP addresses with first run		(1.3)
#		- Fixed bug with sending double quotes				(1.3)
#		---------------------------------------------------------
#		- Changed widget layout and behaviour				(1.4)
#		- Updated the ABOUT button					(1.4)
#		- Added message confirmation					(1.4)
#		- Enabled wrapmode in chatfield					(1.4)
#		- Fixed potential bug with sending large texts			(1.4)
#		- Fixed bug with scrolling of chat text				(1.4)
#		- More code optimizations					(1.4)
#		---------------------------------------------------------
#		- Updated to GTK-server 2.0.9 and code optimizations		(1.4b)
#		---------------------------------------------------------
#		- Changed to embedded GTK :-)					(1.5)
#		- Even more code improvemens					(1.5)
#		- Changed to better async handling				(1.5)
#		- Fixed stupid bug with (nil)					(1.5b)
#		- Fixed bug when configfile is not available			(1.5b)
#		---------------------------------------------------------
#		- Small Adaptation for GTK-server 2.2.7				(1.5c)
#		- Corrected info in ABOUT dialogbox				(1.5c)
#		---------------------------------------------------------
#		- Adapted for newLisp 10					(1.6)
#		- Tested with MacOSX						(1.6)
#		- Removed the obsolete 'integer' command			(1.6)
#
# --------------------------------------------------------------------
#
# USAGE
#
# The chatprogram is server and client at the same time. When somebody
# sends a UDP DGRAM to your IP address, it will be displayed by the chat
# program.
#
# You have to specify the IP address of the remote host in the upper entry,
# with a port. For example: 192.168.1.50:34000. If you do not specify a 
# port, the default port 54000 is used. 
#
# The specified port however is BOTH the remote port AND ALSO the local port,
# where the chat program listens for incoming DGRAMS. So the port number
# should be the same on both sides; also the encryption string must be the
# same.
#
# It is possible to specify a multicast IP address (class D). This is an
# address between 224.0.0.0 and 239.255.255.255. The chat program will
# switch to multicast mode automatically.
# 
# Changing an IP address will take effect after pressing <enter> in the
# IP address field.
#
# Enjoy!
#
# Peter van Eerten
#
#--------------------------------------------------------------------------------------- GTK

# Import GTK-server and create global symbols for GTK function names
(case ostype
    ("Win32" (import "gtk-server.dll" "gtk"))
    ("OSX" (import "libgtk-server.dylib" "gtk"))
    (true (import "libgtk-server.so" "gtk")))

# Now try to find GTK-server configfile
(set 'cfgfile (open "gtk-server.cfg" "read"))
(when (not cfgfile)
    (set 'cfgfile (open "/usr/local/etc/gtk-server.cfg" "read"))
    (when (not cfgfile) (set 'cfgfile (open "/etc/gtk-server.cfg" "read"))))

# No configfile? Exit
(when (not cfgfile)(println "No GTK-server configfile found! Exiting...")(exit))

# Create global GTK symbols
(while (read-line cfgfile)
    (when (and (starts-with (current-line) "FUNCTION_NAME") (regex "gtk_+|gdk_+|g_+" (current-line)))
	(set 'func (chop ((parse (current-line) " ") 2)))
	(set 'lb (append {(lambda()(setq s "} func {")(dolist (x (args))(setq s (string s " " x)))(get-string (gtk s)))}))
	(constant (global (sym func)) (eval-string lb))))

(close cfgfile)

(constant (global 'NULL) "NULL")

#--------------------------------------------------------------------------------------- GUI
#
# GUI definition
#
(context 'GUI)

# Initialize and define window
(define (setup)
    (gtk_init NULL NULL)
    (set 'win (gtk_window_new 0))
    (gtk_window_set_title win "'UDP Chat 1.6'"})
    (gtk_window_set_default_size win 350 350)
    (gtk_window_set_position win 1)
    # Prepare async events
    (gtk_server_connect win "show" "win")
    (gtk_server_timeout 100 win "show")
    # Setup IP address fields
    (set 'iplabel (gtk_label_new "'IP address:'"))
    (gtk_widget_set_usize iplabel 75 10)
    (gtk_misc_set_alignment iplabel 1.0 0.5)
    (set 'ipaddress (gtk_entry_new))
    # Setup alias fields
    (set 'nicklabel (gtk_label_new "Nickname:"))
    (gtk_widget_set_usize nicklabel 75 10)
    (gtk_misc_set_alignment nicklabel 1.0 0.5)
    (set 'nickname (gtk_entry_new))
    # Setup encryption fields
    (set 'enclabel (gtk_label_new "Encryption:"))
    (gtk_widget_set_usize enclabel 75 10)
    (gtk_misc_set_alignment enclabel 1.0 0.5)
    (set 'encryption (gtk_entry_new))
    # Setup frame around edit fields
    (set 'frame1 (gtk_frame_new NULL))
    # Setup buttons
    (set 'aboutbut (gtk_button_new_with_mnemonic "_About"))
    (gtk_widget_set_usize aboutbut 60 30)
    (set 'exitbut (gtk_button_new_with_mnemonic "_Exit"))
    (gtk_widget_set_usize exitbut 60 30)
    # Setup option box for server
    (set 'option1 (gtk_check_button_new_with_label "'Use sound'"))
    (set 'option2 (gtk_check_button_new_with_label "'Use time'"))
    # Setup frame around edit fields
    (set 'frame2 (gtk_frame_new NULL))
    # Setup chatfield
    (set 'txtbuf (gtk_text_buffer_new NULL))
    (set 'chatfield (gtk_text_view_new_with_buffer txtbuf))
    (gtk_text_view_set_wrap_mode chatfield 1)
    (set 'sw (gtk_scrolled_window_new NULL NULL))
    (gtk_scrolled_window_set_policy sw 2 1)
    (gtk_scrolled_window_set_shadow_type sw 1)
    (gtk_container_add sw chatfield)
    (gtk_text_view_set_editable chatfield 0)
    (gtk_text_view_set_wrap_mode chatfield 2)
    # Define text color and style tags - using color names from /usr/lib/X11/rgb.txt
    (gtk_text_buffer_create_tag txtbuf "normal style 0 NULL")
    (gtk_text_buffer_create_tag txtbuf "oblique style 1 NULL")
    (gtk_text_buffer_create_tag txtbuf "italic style 2 NULL")
    (gtk_text_buffer_create_tag txtbuf "centre justification 2 NULL")
    (gtk_server_redefine "gtk_text_buffer_create_tag NONE WIDGET 5 WIDGET STRING STRING STRING NULL")
    (gtk_text_buffer_create_tag txtbuf "black foreground black NULL")
    (gtk_text_buffer_create_tag txtbuf "blue foreground blue NULL")
    (gtk_text_buffer_create_tag txtbuf "red foreground red NULL")
    (gtk_text_buffer_create_tag txtbuf "green foreground DarkGreen NULL")
    # Define text entry
    (set 'entry (gtk_entry_new))
    # Define DIALOG
    (set 'tmp (append "*** UDP Single- and Multicast Chat written in newLisp ***\r\r\tUsing newLisp " (string (sys-info -2)) " with GTK-server " (gtk_server_version) ".\r\r\tVisit http://www.gtk-server.org/ for more info!"))
    (set 'dialog (gtk_message_dialog_new win 0 0 2 (append {"} tmp {"}) "''"))
    # Put widgets to frames - frame1
    (set 'h1box (gtk_hbox_new 0 0))
    (set 'h2box (gtk_hbox_new 0 0))
    (set 'h3box (gtk_hbox_new 0 0))
    (gtk_box_pack_start h1box iplabel 0 0 1)
    (gtk_box_pack_start h1box ipaddress 0 0 1)
    (gtk_box_pack_start h2box nicklabel 0 0 1)
    (gtk_box_pack_start h2box nickname 0 0 1)
    (gtk_box_pack_start h3box enclabel 0 0 1)
    (gtk_box_pack_start h3box encryption 0 0 1)
    (set 'v1box (gtk_vbox_new 0 0))
    (gtk_box_pack_start v1box h1box 0 0 1)
    (gtk_box_pack_start v1box h2box 0 0 1)
    (gtk_box_pack_start v1box h3box 0 0 1)
    (gtk_container_add frame1 v1box)
    # Put widgets to frames - frame2
    (set 'h4box (gtk_hbox_new 0 0))
    (gtk_box_pack_start h4box aboutbut 0 0 1)
    (gtk_box_pack_start h4box exitbut 0 0 1)
    (set 'v2box (gtk_vbox_new 0 0))
    (gtk_box_pack_start v2box h4box 0 0 1)
    (gtk_box_pack_start v2box option1 0 0 1)
    (gtk_box_pack_start v2box option2 0 0 1)
    (gtk_container_add frame2 v2box)
    # Setup box framework to arrange widgets
    (set 'hbox (gtk_hbox_new 0 0))
    (gtk_box_pack_start hbox frame1 0 0 1)
    (gtk_box_pack_start hbox frame2 0 0 1)
    (set 'vbox (gtk_vbox_new 0 0))
    (gtk_box_pack_start vbox hbox 0 0 1)
    (gtk_box_pack_start vbox sw 1 1 1)
    (gtk_box_pack_start vbox entry 0 0 1)
    (gtk_container_add win vbox)
    # Show whole GUI
    (gtk_widget_show_all win)
    # Set focus
    (gtk_widget_grab_focus entry)
    # Allocate memory for text_iterator using random GTK function
    (setq myit (gtk_frame_new NULL))
)

# Put info into widgets
(define (fill widget txt)
    (if (> (length txt) 0) (gtk_entry_set_text widget (append {"} txt {"})))
)

# Retrieve info from widgets
(define (retrieve widget)
    (trim (gtk_entry_get_text widget) "\n")
)

# Define callback signals
(define (callbk)
    (gtk_server_callback "wait")
)

# Define deletion of entry field
(define (del_entry)
    (gtk_editable_delete_text entry 0 -1)
    (gtk_widget_grab_focus entry)
)

# Define a newline
(define (newline)
    (gtk_text_buffer_get_end_iter txtbuf myit)
    (gtk_text_buffer_insert txtbuf myit {"\r"} -1)
)

# Define message routine using colors
(define (info_msg str style1 style2)
    # Replace existing doublequotes and slashes
    (replace "\\" str "\\\\")
    (replace "\"" str "\\\"")
    (gtk_text_buffer_get_end_iter txtbuf myit)
    (gtk_text_buffer_insert_with_tags_by_name txtbuf myit (append {"} str {"}) -1 style1 style2 "normal NULL")
    (set 'mark (gtk_text_buffer_create_mark txtbuf "mymark" myit 0))
    (gtk_text_view_scroll_to_mark chatfield mark 0 1 0.0 1.0)
    (gtk_text_buffer_delete_mark txtbuf mark)
)

# Check if 'use sound' is active - 1: active 0:not
(define (use_sound)
    (int (gtk_toggle_button_get_active option1))
)

# Activate sound
(define (set_sound)
    (gtk_toggle_button_set_active option1 1)
)

# Check if 'use time' is active - 1: active 0:not
(define (use_time)
    (int (gtk_toggle_button_get_active option2))
)

# Activate time
(define (set_time)
    (gtk_toggle_button_set_active option2 1)
)

# Show ABOUT dialog
(define (show_about)
    (gtk_widget_show dialog)
)

# Hide ABOUT dialog
(define (hide_about)
    (gtk_widget_hide dialog)
    (gtk_widget_grab_focus entry)
)

#--------------------------------------------------------------------------------------- NET
#
# All networking stuff
#
(context 'NET)

# Define default connection port
(constant 'default-port 54000)

# Define maximum amount of bytes to receive
(constant 'default-size 1024)

# Define UDP timeout
(constant 'udp-timeout 3000)

# How many times to wait for a confirm
(constant 'confirm-attempts 10)

# Define separator string
(constant 'default-sep "---")

# First setup of multicast or UDP socket on default interface
(define (setup)
(if (get_ip)
    (begin
	# Close existing sockets first
	(if (!= sockout nil) (net-close sockout))
	(if (!= sockin nil) (net-close sockin))
	# Parse IP address
	(set 'tmp (first (parse ipaddress ":")))
	# Check on a multicast address
	(if (and (>= (int (first (parse tmp "."))) 224)(<= (int (first (parse tmp "."))) 239))
	    (begin
		# Setup multicast socket
		(set 'sockout (net-connect ipaddress udpport "multi"))
		(set 'sockin (net-listen udpport ipaddress "multi"))
		(set 'mode 1)
		(GUI:info_msg "Starting in multicast mode." "italic" "black")
	    )
	    (begin
		# Setup UDP socket
		(set 'sockout (net-connect ipaddress udpport "udp"))
		(set 'sockin (net-listen udpport "" "udp"))
		(set 'mode 0)
		(GUI:info_msg "Starting in UDP mode." "italic" "black")
	    )
	)
    )
)
)

# Change sockets when IP address is changed dynamically
(define (dynamic)
    (GUI:newline)
    (GUI:info_msg "Target IP address changed." "italic" "black")
    (if (get_ip)
	(begin
	    # Close existing sockets
	    (if (!= sockout nil) (net-close sockout))
	    (if (!= sockin nil) (net-close sockin))
	    (set 'tmp (first (parse ipaddress ":")))
	    # Check on a multicast address
	    (if (and (>= (int (first (parse tmp "."))) 224)(<= (int (first (parse tmp "."))) 239))
		(begin
		    # Are we in UDP mode?
		    (when (= mode 0)
			(GUI:info_msg " Switching to multicast!" "italic" "black")
			(set 'mode 1)
		    )
		    (GUI:del_entry)
		    # Setup multicast socket
		    (set 'sockout (net-connect ipaddress udpport "multi"))
		    (set 'sockin (net-listen udpport ipaddress "multi"))
		)
		# No multicast address, setup UDP
		(begin
		    # Are we in Multicast mode?
		    (when (= mode 1)
			(GUI:info_msg " Switching to UDP!" "italic" "black")
			(set 'mode 0)
		    )
		    (GUI:del_entry)
		    # Setup UDP socket
		    (set 'sockout (net-connect ipaddress udpport "udp"))
		    (set 'sockin (net-listen udpport "" "udp"))
		)
	    )
	)
    )
)

# Get ip address and port
(define (get_ip)
    (if (!= (regex "[0-9]{1,3}\\.[0-9]{1,3}\\.[0-9]{1,3}\\.[0-9]{1,3}" (string (GUI:retrieve GUI:ipaddress))) nil)
	(begin
	    (set 'ipaddress (first (parse (GUI:retrieve GUI:ipaddress) ":")))
	    (set 'udpport (last (parse (GUI:retrieve GUI:ipaddress) ":")))
	    (if (or (= ipaddress udpport) (= udpport "")) (set 'udpport default-port)(set 'udpport (int udpport)))
	    true
	)
    nil)
)

# Get nickname
(define (get_name)
    (if (< (length (string (GUI:retrieve GUI:nickname))) 1)
	nil
	(set 'nick (GUI:retrieve GUI:nickname))
    )
)

# Get encryption
(define (get_enc)
    (if (< (length (string (GUI:retrieve GUI:encryption))) 1)
	nil
	(set 'code (GUI:retrieve GUI:encryption))
    )
)

# Send to other side
(define (send)
# Check existence of socket
(if (= sockout nil) (setup))
# Setup check
(set 'check 0)
# Check if IP address is available
(if (not get_ip)
    (begin
	(GUI:newline)
	(GUI:info_msg "Please specify an IP address!" "italic" "normal")
    )
    (inc check)
)
# Check if Nickname is available
(if (not get_name)
    (begin
	(GUI:newline)
	(GUI:info_msg "Please specify a nickname!" "italic" "normal")
    )
    (inc check)
)
# Check if Encryption is available
(if (not get_enc)
    (begin
	(GUI:newline)
	(GUI:info_msg "Please specify an encryption!" "italic" "normal")
    )
    (inc check)
)

# Did we pass all 3 checkpoints?
(if (= check 3)
    (begin
	# Get the chatted text
	(set 'tmp (GUI:retrieve GUI:entry))
	# Check if there was really some text
	(if (> (length tmp) 0)
	    (begin
		(set 'send-text (encrypt (append (GUI:retrieve GUI:nickname) default-sep (slice tmp 0 default-size)) (GUI:retrieve GUI:encryption)))
		# Send chat away
		(net-send-to ipaddress udpport send-text sockout)
		# Set large timeout in case UDP travels far
		(set 'counter 0)
		(do-until (or (= counter confirm-attempts)(net-select sockin "read" udp-timeout)) (inc counter))
		# Reap all available data from socket, only last read counts
		(if (net-select sockin "read" 3000000) (set 'rec (net-receive-from sockin default-size)))
		# If really no data then message may be lost
		(if (or (= rec nil) (!= (first rec) (encrypt (append (GUI:retrieve GUI:nickname) default-sep tmp)(GUI:retrieve GUI:encryption))))
		    (begin
			(GUI:newline)
			(GUI:info_msg "No response. Message may be lost." "black" "italic")
		    )
		)
		# Put sent text to widget
		(GUI:newline)
		(if (= (int (GUI:use_time)) 1)
		    (GUI:info_msg (append "[" (nth 3 (parse (date) "[ ]+"0)) "] ") "red" "normal"))
		(GUI:info_msg (append " " (GUI:retrieve GUI:nickname) ": ") "blue" "normal")
		(GUI:info_msg tmp "green" "normal")
		# Find out if sound is used, if so, play BELL
		(if (= (int (GUI:use_sound)) 1) (println (char 7)))
		# Empty entry & put focus here
		(GUI:del_entry)
	    )
	)
    )
)
)

# Define UDP sniffer
(define (retrieve)
    # Check existence of socket
    (if (= sockin nil) (setup))
    # Ip address and encoding filled in? Yes, now sniff UDP
    (if (and (get_ip) (get_enc))
	(begin
	    # Wait for incoming UDP DGRAMS
	    (if (net-select sockin "read" udp-timeout)
		(begin
		    # Receive chatstring on IP:port
		    (set 'tmp (net-receive-from sockin default-size))
		    # Send away immediately to sender as confirmation (when in UDP mode and if received != sent)
		    (if (and (= mode 0) (!= (first tmp) send-text)) (net-send-to (nth 1 tmp) udpport (first tmp) sockout))
		    # Decode to human readable strings
		    (set 'result (parse (encrypt (first tmp) (GUI:retrieve GUI:encryption)) default-sep))
		    # Isolate contents from IP address
		    (set 'tmp (string (last result)))
		    # Put contents in widget
		    (GUI:newline)
		    (if (= (int (GUI:use_time)) 1)
			(GUI:info_msg (append "[" (nth 3 (parse (date) "[ ]+"0)) "] ") "red" "normal"))
		    (GUI:info_msg (append " " (string (first result)) ": ") "blue" "normal")
		    (GUI:info_msg tmp "green" "normal")
		    # Find out if sound is used, if so, play BELL
		    (if (= (int (GUI:use_sound)) 1) (println (char 7)))
		)
	    )
	)
    )
)

#--------------------------------------------------------------------------------------- CFG
#
# All configuration stuff
#
(context 'CFG)

# Read configfile if exists
(define (read_cfg)
    (set 'config (open "chat.cfg" "read"))
    (unless (= config nil)
	(while (read-line config)
	    (set 'data (parse (current-line) " "))
	    (if
		(= (first data) "ipaddress") (GUI:fill GUI:ipaddress (string (last data)))
		(= (first data) "nickname") (GUI:fill GUI:nickname (string (last data)))
		(= (first data) "encryption") (GUI:fill GUI:encryption (string (last data)))
		(and (= (first data) "sound") (= (last data) "1"))(GUI:set_sound)
		(and (= (first data) "time") (= (last data) "1")) (GUI:set_time)
	    )
	)
	(close config)
    )
)

# Create configfile when exiting
(define (write_cfg)
    (set 'config (open "chat.cfg" "write"))
    (write-line config (append "ipaddress " (GUI:retrieve GUI:ipaddress)) )
    (write-line config (append "nickname " (GUI:retrieve GUI:nickname)) )
    (write-line config (append "encryption " (GUI:retrieve GUI:encryption)) )
    (write-line config (append "sound " (string (GUI:use_sound))) )
    (write-line config (append "time " (string (GUI:use_time))) )
    (close config)
)

#-------------------------------------------------------------------------------------- MAIN
#
# Main program
#
(context 'MAIN)

# Setup GTK and GUI
(GUI:setup)
(CFG:read_cfg)
(NET:setup)

# Mainloop
(while (and (!= event GUI:exitbut) (!= event GUI:win))
    # Get callback signal
    (set 'event (GUI:callbk))
    # Dynamically change socket if necessary
    (if (= event GUI:ipaddress) (NET:dynamic))
    # Check if something was sent
    (if (= event GUI:entry) (NET:send))
    # Check if ABOUT button was pressed
    (if (= event GUI:aboutbut) (GUI:show_about))
    # Check if ABOUT dialog must be closed
    (if (= event GUI:dialog) (GUI:hide_about))
    # Check if something has arrived
    (NET:retrieve)
)

# Save configuration
(CFG:write_cfg)

# Exit newLisp
(exit)