diff options
Diffstat (limited to 'Hermes')
| -rw-r--r-- | Hermes/Hermes_Gui1.3.rkt | 196 | ||||
| -rw-r--r-- | Hermes/Makefile | 3 | ||||
| -rw-r--r-- | Hermes/TODO | 17 | ||||
| -rw-r--r-- | Hermes/client.rkt | 108 | ||||
| -rw-r--r-- | Hermes/modules/general.rkt | 24 | ||||
| -rw-r--r-- | Hermes/server.rkt | 276 |
6 files changed, 624 insertions, 0 deletions
diff --git a/Hermes/Hermes_Gui1.3.rkt b/Hermes/Hermes_Gui1.3.rkt new file mode 100644 index 0000000..ba239c3 --- /dev/null +++ b/Hermes/Hermes_Gui1.3.rkt @@ -0,0 +1,196 @@ +#lang racket +(require racket/gui/base) +;Author:Douglas Richardson +;Notes:Our GUI mostly deals with lists of a list of 3 strings and a number +;although the number is always delt with locally +;When using user-message you need to give it a list of 3 things +;The name of the user as a string, what they said as a string, +;and the color as a string + +;Object stuff + +(provide make-gui) + +(define (make-gui) + (begin + ;;Create the frame + (define main-frame (new frame% + [label "Example5"] + [width 500] + [height 700] + )) + ;;Editing canvas + (define (do-stuff-paint paint-canvas paint-dc) + (do-more-stuff-paint listy paint-canvas paint-dc)) + + (define (do-more-stuff-paint paint-listy paint-canvas paint-dc) + (if (null? paint-listy) + '() + (begin + (re-draw-message (get-username-from-list (car paint-listy)) + (get-message-from-list (car paint-listy)) + (get-color-from-list (car paint-listy)) + (get-height-from-list (car paint-listy))) + (do-more-stuff-paint (cdr paint-listy) paint-canvas paint-dc)))) + + (define read-canvas (new canvas% + [parent main-frame] + [paint-callback do-stuff-paint] + [style '(hscroll vscroll)] + )) + + (send read-canvas init-auto-scrollbars #f #f 0 0);Start with no scrollbars + ;;text-field stuff + (define (text-feild-callback callback-type other-thing) + (if (equal? 'text-field-enter (send other-thing get-event-type)) + (button-do-stuff 'irrelevant 'not-used) + '())) + + (define input (new text-field% + [parent main-frame] + [label "Username:"] + [callback text-feild-callback] + )) + ;;button stuff + (define (button-do-stuff b e);b and e do nothing :/ + (begin + (if (color-change-request? (send input get-value)) + (set! my-color (get-color-from-input (send input get-value))) + (if (< 0 (string-length (send input get-value))) + (send-message (send input get-value) my-color);; + '())) + (send input set-value "") + )) + (define send-button (new button% + [parent main-frame] + [label "Send"] + [callback button-do-stuff])) + ;;I forget what these do but don't move them + (define dc (send read-canvas get-dc)) + (send dc set-scale 1 1) + (send dc set-text-foreground "black") + ;;messaging stuff + + (define (user-message-parse string start) + (begin + (define (helper str index) + (if (eq? (string-ref str (+ start index)) #\~) + (substring str start (+ start index)) + (helper str (+ index 1)))) + (helper string 0))) + + (define (user-message onetrueinput) + (begin + (define username (user-message-parse onetrueinput 0)) + (define input (user-message-parse onetrueinput (+ 1(string-length username)))) + (define color (substring onetrueinput (+ 2 (string-length username) (string-length input)))) + (send dc set-text-foreground color) + (send dc draw-text (string-append username ":" input) 0 height) + (set! listy (appendlist listy (list username input color height))) + (set! height (+ height 15)) + (set! min-v-size (+ min-v-size 15)) + (if (> (* 20 (string-length input)) min-h-size) + (set! min-h-size (* 20 (string-length input))) + '()) + (send read-canvas init-auto-scrollbars min-h-size min-v-size 0 1) + )) + ;;Add a function that parces input from a string and extracts elements + + ;;This probably won't change... + (define (send-message input color) + (user-message (string-append name "~" input "~" color))) + ;;Although re-draw is kind of misleading, it is just print the whole + ;;list of strings to the screen + (define (re-draw-message username input color in-height) + (begin + (send dc set-text-foreground color) + (send dc draw-text (string-append username ":" input) 0 in-height) + )) + + (define (update given-list) + (begin (set! listy '()) + (set! height 0) + (update-helper given-list))) + + (define (update-helper given-list) + (if (null? given-list) + '() + (if (null? (car given-list)) + '() + (begin (user-message + (get-username-from-list (car given-list)) + (get-message-from-list (car given-list)) + (get-color-from-list (car given-list))) + (update-helper (cdr given-list)))))) + + ;;Variables go below functions + (define name "Me") + (define min-h-size 80) + (define min-v-size 30) + (define listy (list (list "Server" "Connected" "Red" 0))) + (define my-color "black") + (define height 15) + ;;dispatch goes below that + (define (dispatch command) + (cond ((eq? command 'show) (send main-frame show #t)) + ((eq? command 'send) send-message) + ((eq? command 'set-name) (lambda (newname) (if (string? newname) + (set! name newname) + (print "Thats not good")))) + ((eq? command 'recieve-message) user-message) + ((eq? command 'get-list) listy) + ((eq? command 'set-list) update) + ;;Something up with that + (else (error "Invalid Request" command)) + )) + ;;dispatch goes below that + dispatch)) + + +;This one displays information + + + + +;Initilize scrolling + +;Then we need to find out if we need them or not. + +;Listy is going to be a list of lists of strings +;each element in listy will contain three strings +;the username the message they said and the color they used +;The the height the message should display at + + +(define (appendlist listoflist add-to-end) + (if (null? listoflist) + (cons add-to-end '()) + (cons (car listoflist) (appendlist (cdr listoflist) add-to-end)))) + +(define (get-username-from-list in-list) + (car in-list)) + +(define (get-message-from-list in-list) + (car (cdr in-list))) + +(define (get-color-from-list in-list) + (car (cdr (cdr in-list)))) + +(define (get-height-from-list in-list) + (car (cdr (cdr (cdr in-list))))) + + + +;this one is a crap version of justpressing the enter key +(define (color-change-request? given-string) + (if (> (string-length given-string) 7) + (if (equal? (substring given-string 0 6) "/color") + #t + #f) + #f)) + +(define (get-color-from-input given-string) + (substring given-string 7)) +;(define thing1 (make-gui)) +;(define thing2 (make-gui)) + diff --git a/Hermes/Makefile b/Hermes/Makefile new file mode 100644 index 0000000..c580a71 --- /dev/null +++ b/Hermes/Makefile @@ -0,0 +1,3 @@ +# Remove temporary files +clean: + rm -rf *~ *.out *.conf *.txt diff --git a/Hermes/TODO b/Hermes/TODO new file mode 100644 index 0000000..bbc2930 --- /dev/null +++ b/Hermes/TODO @@ -0,0 +1,17 @@ +FEATURES +5. parser in the client side should do something similar (/color, /quit) +16. plain tcp -> ssl based +17. fix breaks for improper disconnects from clients +18. Add topics after project completion +** regexes to parse strings for different formats -related to 5 +** align code better for readability + + +GOOD TO HAVE BUT NOT NECESSARY +7. maybe fiddle around with irc library (we leave this for future opl classes) no time got other classes +*14. bye message prompt for clients part of session stickiness +*15. Session stickiness for clients. Log received comms to a local file. +additionally save user details and prompt user to use defaults or create +new ones +10. authentication for databases - to avoid dependencies this is left out +** whispers aren't currently logged - its on purpose diff --git a/Hermes/client.rkt b/Hermes/client.rkt new file mode 100644 index 0000000..64710bb --- /dev/null +++ b/Hermes/client.rkt @@ -0,0 +1,108 @@ +#lang racket + +(require "modules/general.rkt" "Hermes_Gui1.3.rkt") +(require math/base) ;; for random number generation +;; TODO clean up string message output and alignment +;; TODO close ports after done +;; i.e. seconds and minutes hours specifically +;; author: Ibrahim Mkusa +;; about: print and read concurrently +;; notes: output may need to be aligned and formatted nicely + + +; we will prompt for these in the gui +(define host3 "localhost") +(define port-num 4321) +(define sleep-t 0.1) + +; we won't need this. Just me being overzealous +(define hermes-conf (open-output-file "./hermes_client.conf" #:exists'append)) +(define hermes-conf-s (make-semaphore 1)) + +(define convs-out (open-output-file "./convs_client.out" #:exists 'append)) +(define convs-out-s (make-semaphore 1)) + +(define error-out (open-output-file "./error_client.out" #:exists 'append)) +(define error-out-s (make-semaphore 1)) + +; custodian for client connections +(define main-client-cust (make-custodian)) +; make connection to server +(define (client port-no) + (parameterize ([current-custodian main-client-cust]) + ;; connect to server at port 8080 + (define-values (in out) (tcp-connect host3 port-no)) ;; define values + ;; binds to multiple values akin to unpacking tuples in python + + ; store username to a file for later retrieval along with relevent + ; info used for authentication with server + (displayln "What's your name?") + (define username (read-line)) + + ;send the username to the server (username in out) + (displayln username out) + (flush-output out) + + (define a (thread + (lambda () + (displayln-safe "Starting receiver thread." error-out-s error-out) + (let loop [] + (receive-messages in) + (sleep sleep-t) + (loop))))) + (define t (thread + (lambda () + (displayln-safe "Starting sender thread." error-out-s error-out) + (let loop [] + (send-messages username out) + (sleep sleep-t) + (loop))))) + (displayln-safe "Now waiting for sender thread." error-out-s error-out) + (thread-wait t) ;; returns prompt back to drracket + (displayln-safe "Closing client ports." error-out-s error-out) + (close-input-port in) + (close-output-port out)) + (custodian-shutdown-all main-client-cust)) + + +;; sends a message to the server +(define (send-messages username out) + ; get current time + (define date-today (seconds->date (current-seconds) #t)) + ;TODO pad the second if its only 1 character + (define date-print (string-append (number->string (date-hour date-today)) + ":" + (number->string (date-minute date-today)) + ":" + (number->string (date-second date-today)) + " | ")) + ;; read, quits when user types in "quit" + (define input (read-line)) + ; TODO /quit instead of quit + (cond ((string=? input "quit") + (displayln (string-append date-print username " signing out. See ya!") out) + (flush-output out) + (close-output-port error-out) + (close-output-port convs-out) + (exit))) + + (displayln (string-append date-print username ": " input) out) + (flush-output out)) + +; receives input from server and displays it to stdout +(define (receive-messages in) + ; retrieve a message from server + (define evt (sync (read-line-evt in))) + + (cond [(eof-object? evt) + (displayln-safe "Server connection closed." error-out-s error-out) + (custodian-shutdown-all main-client-cust) + ;(exit) + ] + [(string? evt) + (displayln-safe evt convs-out-s convs-out)] ; could time stamp here or to send message + [else + (displayln-safe (string-append "Nothing received from server for 2 minutes.") convs-out-s convs-out)])) + +(displayln-safe "Starting client." error-out-s error-out) +(define stop-client (client 4321)) diff --git a/Hermes/modules/general.rkt b/Hermes/modules/general.rkt new file mode 100644 index 0000000..b33eb8a --- /dev/null +++ b/Hermes/modules/general.rkt @@ -0,0 +1,24 @@ +#lang racket + +(provide displayln-safe) +;; Several threads may want to print to stdout, so lets make things civil +; constant always available +(define stdout (make-semaphore 1)) + +; prints to stdout with an optional output port +; requires a specified semaphore for the optional output port +(define displayln-safe + (lambda (a-string [a-semaphore stdout] [a-output-port (current-output-port)]) + (cond [(not (and (eq? a-semaphore stdout) (eq? a-output-port (current-output-port)))) + (semaphore-wait a-semaphore) + (semaphore-wait stdout) + (displayln a-string a-output-port) + (flush-output a-output-port) + (displayln a-string) + (semaphore-post stdout) + (semaphore-post a-semaphore)] + [else + (semaphore-wait stdout) + (displayln a-string) + (semaphore-post stdout)]))) + diff --git a/Hermes/server.rkt b/Hermes/server.rkt new file mode 100644 index 0000000..9b1a171 --- /dev/null +++ b/Hermes/server.rkt @@ -0,0 +1,276 @@ +#lang racket + +(require "modules/general.rkt") +(require math/base) ;; for random number generation + + +(define welcome-message "Welcome to Hermes coms. Type your message below") +(define successful-connection-m "Successfully connected to a client. Sending client a welcome message.") + +(define sleep-t 0.1) + +; track number of connections with closure +(define (make-count no-count) + (define (increment) + (set! no-count (+ no-count 1)) + no-count) + (define (decrement) + (set! no-count (- no-count 1)) + no-count) + (define (current-count) + no-count) + (define (dispatch m) + (cond [(eq? m 'increment) increment] + [(eq? m 'decrement) decrement] + [(eq? m 'current-count) current-count])) + dispatch) +(define c-count (make-count 0)) +; a semaphore to control access to c-count +(define c-count-s (make-semaphore 1)) + + +; track list of input output port pairs in a list contained in a closure +(define (make-connections connections) + (define (null-cons?) + (null? connections)) + (define (add username in out) + (set! connections (append connections (list (list username in out)))) + connections) + (define (cons-list) + connections) + (define (remove-ports in out) + (set! connections + (filter + (lambda (ports) + (if (and (eq? in (get-input-port ports)) + (eq? out (get-output-port ports))) + #f + #t)) + connections))) + (define (dispatch m) + (cond [(eq? m 'null-cons) null-cons?] + [(eq? m 'cons-list) cons-list] + [(eq? m 'remove-ports) remove-ports] + [(eq? m 'add) add])) + dispatch) +(define c-connections (make-connections '())) +; a semaphore to control acess to c-connections +(define connections-s (make-semaphore 1)) ;; control access to connections + +; Track received messages in a closure +(define (make-messages messages) + (define (add message) + (set! messages (append messages (list message))) + messages) + (define (mes-list) + messages) + (define (remove-top) + (set! messages (rest messages)) + messages) + (define (dispatch m) + (cond [(eq? m 'add) add] + [(eq? m 'mes-list) mes-list] + [(eq? m 'remove-top) remove-top])) + dispatch) +(define c-messages (make-messages '())) +; semaphore to control access to c-messages +(define messages-s (make-semaphore 1)) ;; control access to messages + +; two files to store error messages, and channel conversations +(define error-out (open-output-file "./error_server.txt" #:exists 'append)) +(define convs-out (open-output-file "./conversations_server.txt" #:exists 'append)) +(define error-out-s (make-semaphore 1)) +(define convs-out-s (make-semaphore 1)) +; TODO finish logging all error related messages to +(define (serve port-no) + (define main-cust (make-custodian)) + (parameterize ([current-custodian main-cust]) + (define listener (tcp-listen port-no 5 #t)) + (define (loop) + (receive-clients listener) + (loop)) + (displayln-safe "Starting up the listener." error-out-s error-out) + (thread loop) + (displayln-safe "Listener successfully started." error-out-s error-out) + ;; Create a thread whose job is to simply call broadcast iteratively + (thread (lambda () + (displayln-safe "Broadcast thread started!\n") + (let loopb [] + (sleep sleep-t) ;; wait 0.5 secs before beginning to broadcast + (broadcast) + (loopb))))) + (lambda () + (displayln-safe "Goodbye, shutting down all services" error-out-s error-out) + (semaphore-wait error-out-s) + (semaphore-wait convs-out-s) + (close-output-port error-out) + (close-output-port convs-out) + (semaphore-post error-out-s) + (semaphore-post convs-out-s) + (custodian-shutdown-all main-cust))) + +(define (receive-clients listener) + (define cust (make-custodian)) + (parameterize ([current-custodian cust]) + (define-values (in out) (tcp-accept listener)) + + ;TODO retrive user name for client here + ; do some error checking + (define username-evt (sync (read-line-evt in 'linefeed))) + + + + ; increment number of connections + (semaphore-wait c-count-s) + ((c-count 'increment)) + (semaphore-post c-count-s) + + (displayln-safe successful-connection-m) + (displayln welcome-message out) + ;; print to server log and client + (define print-no-users (string-append "Number of users in chat: " + (number->string ((c-count 'current-count))))) + (displayln print-no-users out) + (displayln-safe print-no-users convs-out-s convs-out) + (flush-output out) + (semaphore-wait connections-s) + ; TODO add in a username so we have (username input output) + ((c-connections 'add) username-evt in out) + (semaphore-post connections-s) + + ; start a thread to deal with specific client and add descriptor value to the list of threads + (define threadcom (thread (lambda () + (chat_with_client in out)))) ; comms between server and particular client + + ;; Watcher thread: + ;; kills current thread for waiting too long for connection from + (thread (lambda () + (displayln-safe (string-append + "Started a thread to kill hanging " + "connecting threads")) + (sleep 1360) + (custodian-shutdown-all cust))))) + +; whisper selector for the username and message +(define (whisper-info exp) + (cadr exp)) + +(define (whisper-to exp) + (caddr exp)) + +(define (whisper-message exp) + (cadddr exp)) + +(define (chat_with_client in out) + ; deals with queueing incoming messages for server to broadcast to all clients + (define (something-to-say in) + (define evt-t0 (sync (read-line-evt in 'linefeed))) + (cond [(eof-object? evt-t0) + (semaphore-wait connections-s) + ((c-connections 'remove-ports) in out) + (semaphore-post connections-s) + ; TODO some form of identification for this client + (displayln-safe "Connection closed. EOF received" error-out-s error-out) + (semaphore-wait c-count-s) + ((c-count 'decrement)) + (semaphore-post c-count-s) + ;(exit) + (kill-thread (current-thread))] + [(string? evt-t0) + ; use regexes to evaluate received input from client + (define whisper (regexp-match #px"(.*)/whisper\\s+(\\w+)\\s+(.*)" evt-t0)) ; is client trying to whisper to someone + (define list-count (regexp-match #px"(.*)/list\\s+count\\s*" evt-t0)) ;; is client asking for number of logged in users + (define list-users (regexp-match #px"(.*)/list\\s+users\\s*" evt-t0)) ;; user names + ; do something whether it was a message, a whisper, request for number of users and so on + (cond [whisper + (semaphore-wait connections-s) + ; get output port for user + (define that-user-ports + (first (filter + (lambda (ports) + (if (string=? (whisper-to whisper) (get-username ports)) + #t + #f)) + ((c-connections 'cons-list))))) + ; try to send that user the whisper + (if (port-closed? (get-output-port that-user-ports)) + (begin + (displayln "User is unavailable" out) + (flush-output out)) + (begin + (displayln (string-append (whisper-info whisper) (whisper-message whisper)) + (get-output-port that-user-ports)) + (flush-output (get-output-port that-user-ports)))) + (semaphore-post connections-s)] + [list-count + ;;should put a semaphore on connections + (semaphore-wait c-count-s) + (semaphore-wait connections-s) + (define no-of-users (string-append "Number of users in chat: " + (number->string ((c-count 'current-count))))) + (displayln no-of-users out) + (flush-output out) + (semaphore-post connections-s) + (semaphore-post c-count-s) + ] + [list-users + (semaphore-wait connections-s) + ; map over connections sending the username to the client + (displayln "Here is a list of users in chat." out) + (map + (lambda (ports) + (displayln (get-username ports) out)) + ((c-connections 'cons-list))) + (flush-output out) + (semaphore-post connections-s)] + [else + ; (displayln-safe evt-t0) debug purposes + (semaphore-wait messages-s) + ; evaluate it . + ((c-messages 'add) evt-t0) + (semaphore-post messages-s)])] + [else + (displayln-safe "Timeout waiting. Nothing received from client")])) + + ; Executes methods above in another thread + (thread (lambda () + (let loop [] + (something-to-say in) + ; (sleep 1) + (loop))))) + +; extracts output port from a list pair of input and output port +(define (get-output-port ports) + (caddr ports)) + +; extracts input port +(define (get-input-port ports) + (cadr ports)) + +; extract username +(define (get-username ports) + (car ports)) + +; broadcasts received message from clients periodically +; TODO before broadcasting the message make sure the ports is still open +; no EOF if it is remove client from connections +(define broadcast + (lambda () + (semaphore-wait messages-s) + (cond [(not (null? ((c-messages 'mes-list)))) + (begin (map + (lambda (ports) + (if (not (port-closed? (get-output-port ports))) + (begin + (displayln (first ((c-messages 'mes-list))) (get-output-port ports)) + (flush-output (get-output-port ports))) + (displayln-safe "Failed to broadcast. Port not open." error-out-s error-out))) + ((c-connections 'cons-list))) + (displayln-safe (first ((c-messages 'mes-list))) convs-out-s convs-out) + ;; remove top message + ((c-messages 'remove-top)) + (displayln "Message broadcasted"))]) + (semaphore-post messages-s))) + +(define stop-server (serve 4321)) ;; start server then close with stop +(displayln-safe "Server process started\n" error-out-s error-out) |