iskm/Hermes
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fiddled around with it for a bit

Browse Source 
I mostly added a few safties onto the string-lenght and substring
functions so they wouldn't cause a crash, but now somewhere there is
some error where string-append is trying to append to something that
isn't a string, but I have no idea where it is.
This commit is contained in:
Douglas-Richardson 2017-04-22 14:52:46 -04:00
parent 5e3bdbeeb4
commit aebda4ef57
5 changed files with 105 additions and 246 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

@ -9,3 +9,6 @@
# ignore racket compile files # ignore racket compile files
*.dep *.dep
*.zo *.zo
#ignore backup files
*.bak

84
Hermes/Hermes_Gui1.3.rkt
View File

@ -15,7 +15,7 @@
(begin (begin
;;Create the frame ;;Create the frame
(define main-frame (new frame% (define main-frame (new frame%
[label "Example5"] [label "Hermes"]
[width 500] [width 500]
[height 700] [height 700]
)) ))
@ -54,13 +54,18 @@
;;button stuff ;;button stuff
(define (button-do-stuff b e);b and e do nothing :/ (define (button-do-stuff b e);b and e do nothing :/
(begin (begin
(if (color-change-request? (send input get-value)) (define given-input (send input get-value))
(set! my-color (get-color-from-input (send input get-value))) (if (string? given-input)
(if (< 0 (string-length (send input get-value))) (if (color-change-request? given-input)
(set! my-color (get-color-from-input given-input))
(if (quit-request? given-input)
(write "quit" the-output-port)
(if (< 0 (string-length-safe given-input))
(send-message (send input get-value) my-color);; (send-message (send input get-value) my-color);;
'())) '())))
(send input set-value "") '())
)) (send input set-value "")))
(define send-button (new button% (define send-button (new button%
[parent main-frame] [parent main-frame]
[label "Send"] [label "Send"]
@ -72,33 +77,39 @@
;;messaging stuff ;;messaging stuff
(define (user-message-parse string start) (define (user-message-parse string start)
(begin
(define (helper str index) (define (helper str index)
(if (string? string)
(if (>= (+ start index) (string-length-safe string))
(display string);;Something went wrong
(if (eq? (string-ref str (+ start index)) #\~) (if (eq? (string-ref str (+ start index)) #\~)
(substring str start (+ start index)) (substring-s str start (+ start index))
(helper str (+ index 1)))) (helper str (+ index 1))))
(helper string 0))) '()))
(helper string start))
(define (user-message onetrueinput) (define (user-message onetrueinput)
(begin (if (string? onetrueinput)
(let();;This is kind of stupid but whatever it works.
(define username (user-message-parse onetrueinput 0)) (define username (user-message-parse onetrueinput 0))
(define input (user-message-parse onetrueinput (+ 1(string-length username)))) (define user-input (user-message-parse onetrueinput (+ 1(string-length-safe username))))
(define color (substring onetrueinput (+ 2 (string-length username) (string-length input)))) (define color (substring-s onetrueinput (+ 2 (string-length-safe username) (string-length-safe user-input)) (string-length-safe onetrueinput)))
(send dc set-text-foreground color) (send dc set-text-foreground color)
(send dc draw-text (string-append username ":" input) 0 height) (send dc draw-text (string-append username ":" user-input) 0 height)
(set! listy (appendlist listy (list username input color height))) (set! listy (appendlist listy (list username user-input color height)))
(set! height (+ height 15)) (set! height (+ height 15))
(set! min-v-size (+ min-v-size 15)) (set! min-v-size (+ min-v-size 15))
(if (> (* 20 (string-length input)) min-h-size) (if (> (* 20 (string-length-safe user-input)) min-h-size)
(set! min-h-size (* 20 (string-length input))) (set! min-h-size (* 20 (string-length-safe user-input)))
'()) '())
(send read-canvas init-auto-scrollbars min-h-size min-v-size 0 1) (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 ;;Add a function that parces input from a string and extracts elements
(define the-output-port (open-output-string))
;;This probably won't change... ;;This probably won't change...
(define (send-message input color) (define (send-message input color)
(user-message (string-append name "~" input "~" color))) (write (string-append name "~" input "~" color) the-output-port))
;;Although re-draw is kind of misleading, it is just print the whole ;;Although re-draw is kind of misleading, it is just print the whole
;;list of strings to the screen ;;list of strings to the screen
(define (re-draw-message username input color in-height) (define (re-draw-message username input color in-height)
@ -138,8 +149,9 @@
(set! name newname) (set! name newname)
(print "Thats not good")))) (print "Thats not good"))))
((eq? command 'recieve-message) user-message) ((eq? command 'recieve-message) user-message)
((eq? command 'get-list) listy) ;((eq? command 'get-list) listy)
((eq? command 'set-list) update) ;((eq? command 'set-list) update)
((eq? command 'get-output-port) the-output-port)
;;Something up with that ;;Something up with that
(else (error "Invalid Request" command)) (else (error "Invalid Request" command))
)) ))
@ -179,18 +191,38 @@
(define (get-height-from-list in-list) (define (get-height-from-list in-list)
(car (cdr (cdr (cdr in-list))))) (car (cdr (cdr (cdr in-list)))))
(define (get-color-from-input input)
(substring-s input 6 (string-length-safe input)))
;this one is a crap version of justpressing the enter key ;this one is a crap version of justpressing the enter key
(define (color-change-request? given-string) (define (color-change-request? given-string)
(if (> (string-length given-string) 7) (if (> (string-length-safe given-string) 7)
(if (equal? (substring given-string 0 6) "/color") (if (equal? (substring-s given-string 0 6) "/color")
#t #t
#f) #f)
#f)) #f))
(define (get-color-from-input given-string)
(substring given-string 7)) (define (quit-request? given-string)
(if (>= (string-length-safe given-string) 5)
(if ((equal? substring-s given-string 0 5) "/quit")
#t
#f)
#f))
(define (string-length-safe string)
(if (string? string)
(string-length string)
0))
(define (substring-s string start end)
(if (<= start end)
(if (<= end (string-length-safe string))
(substring string start end)
"")
""))
;(define thing1 (make-gui)) ;(define thing1 (make-gui))
;(define thing2 (make-gui)) ;(define thing2 (make-gui))

25
Hermes/client.rkt
View File

@ -25,6 +25,7 @@
(define error-out (open-output-file "./error_client.out" #:exists 'append)) (define error-out (open-output-file "./error_client.out" #:exists 'append))
(define error-out-s (make-semaphore 1)) (define error-out-s (make-semaphore 1))
(define gui (make-gui))
; custodian for client connections ; custodian for client connections
(define main-client-cust (make-custodian)) (define main-client-cust (make-custodian))
; make connection to server ; make connection to server
@ -38,9 +39,10 @@
; info used for authentication with server ; info used for authentication with server
(displayln "What's your name?") (displayln "What's your name?")
(define username (read-line)) (define username (read-line))
((gui 'set-name) username)
(gui 'show)
;send the username to the server (username in out) ;send the username to the server (username in out)
(displayln username out) ;(displayln username out)
(flush-output out) (flush-output out)
(define a (thread (define a (thread
@ -77,16 +79,22 @@
(number->string (date-second date-today)) (number->string (date-second date-today))
" | ")) " | "))
;; read, quits when user types in "quit" ;; read, quits when user types in "quit"
(define input (read-line)) ;(define input (read-line))
(define input (get-output-string (gui 'get-output-port)))
; TODO /quit instead of quit ; TODO /quit instead of quit
(cond ((string=? input "quit") (cond ((string=? input "quit")
(displayln (string-append date-print username " signing out. See ya!") out) ;(displayln (string-append date-print username " signing out. See ya!") out)
(flush-output out) (flush-output out)
(close-output-port error-out) (close-output-port error-out)
(close-output-port convs-out) (close-output-port convs-out)
(exit))) (exit)))
(displayln (string-append date-print username ": " input) out) ;(displayln (string-append date-print username ": " input) out)
(if (not (null? input))
(begin
(display input)
(displayln input out))
'())
(flush-output out)) (flush-output out))
; receives input from server and displays it to stdout ; receives input from server and displays it to stdout
@ -100,9 +108,12 @@
;(exit) ;(exit)
] ]
[(string? evt) [(string? evt)
(displayln-safe evt convs-out-s convs-out)] ; could time stamp here or to send message ;(displayln-safe evt convs-out-s convs-out)] ; could time stamp here or to send message
((gui 'recieve-message) evt)]
[else [else
(displayln-safe (string-append "Nothing received from server for 2 minutes.") convs-out-s convs-out)])) (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) (displayln-safe "Starting client." error-out-s error-out)
(define stop-client (client 4321)) (define stop-client (client 4321))

25
Hermes/server.rkt
View File

@ -126,10 +126,10 @@
(semaphore-post c-count-s) (semaphore-post c-count-s)
(displayln-safe successful-connection-m) (displayln-safe successful-connection-m)
(displayln welcome-message out) ;(displayln welcome-message out)
;; print to server log and client ;; print to server log and client
(define print-no-users (string-append "Number of users in chat: " (define print-no-users (string-append "Server~Number of users in chat: "
(number->string ((c-count 'current-count))))) (number->string ((c-count 'current-count))) "~Red"))
(displayln print-no-users out) (displayln print-no-users out)
(displayln-safe print-no-users convs-out-s convs-out) (displayln-safe print-no-users convs-out-s convs-out)
(flush-output out) (flush-output out)
@ -195,7 +195,7 @@
; try to send that user the whisper ; try to send that user the whisper
(if (port-closed? (get-output-port that-user-ports)) (if (port-closed? (get-output-port that-user-ports))
(begin (begin
(displayln "User is unavailable" out) (displayln "Server~User is unavailable~red" out)
(flush-output out)) (flush-output out))
(begin (begin
(displayln (string-append (whisper-info whisper) (whisper-message whisper)) (displayln (string-append (whisper-info whisper) (whisper-message whisper))
@ -206,8 +206,9 @@
;;should put a semaphore on connections ;;should put a semaphore on connections
(semaphore-wait c-count-s) (semaphore-wait c-count-s)
(semaphore-wait connections-s) (semaphore-wait connections-s)
(define no-of-users (string-append "Number of users in chat: " (define no-of-users (string-append "Server~Number of users in chat: "
(number->string ((c-count 'current-count))))) (number->string ((c-count 'current-count)))
"~red"))
(displayln no-of-users out) (displayln no-of-users out)
(flush-output out) (flush-output out)
(semaphore-post connections-s) (semaphore-post connections-s)
@ -216,10 +217,13 @@
[list-users [list-users
(semaphore-wait connections-s) (semaphore-wait connections-s)
; map over connections sending the username to the client ; map over connections sending the username to the client
(displayln "Here is a list of users in chat." out) (displayln "Server~Here is a list of users in chat.~red" out)
(map (map
(lambda (ports) (lambda (ports)
(displayln (get-username ports) out)) (displayln (string-append
"Server~"
(get-username ports)
"~red")out))
((c-connections 'cons-list))) ((c-connections 'cons-list)))
(flush-output out) (flush-output out)
(semaphore-post connections-s)] (semaphore-post connections-s)]
@ -262,7 +266,10 @@
(lambda (ports) (lambda (ports)
(if (not (port-closed? (get-output-port ports))) (if (not (port-closed? (get-output-port ports)))
(begin (begin
(displayln (first ((c-messages 'mes-list))) (get-output-port ports)) (displayln (string-append "Server~"
(first ((c-messages 'mes-list)))
"~red"
) (get-output-port ports))
(flush-output (get-output-port ports))) (flush-output (get-output-port ports)))
(displayln-safe "Failed to broadcast. Port not open." error-out-s error-out))) (displayln-safe "Failed to broadcast. Port not open." error-out-s error-out)))
((c-connections 'cons-list))) ((c-connections 'cons-list)))

194
Hermes_Gui1.2.rkt
View File

@ -1,194 +0,0 @@
#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
(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))