/
server.ss
80 lines (77 loc) · 3.93 KB
/
server.ss
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Copyright 2009 Ian McEwen ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;This file is part of the Code-Immersion software collaboration framework. ;
; ;
; Code-Immersion is free software: you can redistribute it and/or modify ;
; it under the terms of the GNU Affero General Public License as published ;
; by the Free Software Foundation, either version 3 of the License, or ;
; (at your option) any later version. ;
; ;
; Code-Immersion is distributed in the hope that it will be useful, ;
; but WITHOUT ANY WARRANTY; without even the implied warranty of ;
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;
; GNU Affero General Public License for more details. ;
; ;
; You should have received a copy of the GNU Affero General Public License ;
; along with Code-Immersion. If not, see <http://www.gnu.org/licenses/>. ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#lang scheme
(require scheme/tcp)
(provide server)
(require "utilities.ss")
(require "config.ss")
;new testing server just prints out what it's given. To be moved later, probably into a package of tests.
(define (new-server #:port [port SERVER-PORT])
(let ([listener (tcp-listen port)])
(let loop ()
(let-values ([(client->me me->client)
(tcp-accept listener)])
(let ([s-read (read client->me)])
(print s-read))
(close-output-port me->client)
(close-input-port client->me))
(loop))))
;Registration and getting of output ports
(define-values (register-client get-output-port-list)
(let ([output-port-list '()])
(values
(λ (port) (file-stream-buffer-mode port 'none) (set! output-port-list (cons port output-port-list)) (write '("server" "text" "Registered.") port))
(λ () output-port-list))))
;Dispatching text (the function that actually does it)
(define (dispatch name type message)
(for ([port (get-output-port-list)])
(with-handlers (((lambda (exn) #t) (lambda (exn) (ignoring-errors (close-output-port port)) #t)))
(write `(,name ,type ,message) port))))
;The server! This could possibly be better-named. Anyway, configurable port --
;for now assuming that we want it to just listen on every address. Right now,
;only sending of source really works.
;TODO: Make everything else work again
(define (server #:port [port SERVER-PORT])
(define-listener-and-verifier port #f
(
;Send source to the client (AGPL compliance).
[(equal? type "source")
(write (print-all-source) me->client)
(close-output-port me->client)]
;TODO: Write some sort of interactive help.
[(equal? type "help")
(write "Help is not yet implemented" me->client)
(close-output-port me->client)]
; Registration function -- currently sends two strings then
; causes an exit on the clientside
[(equal? type "register")
(register-client me->client)]
;Dispatching text
[(equal? type "text")
(dispatch name type message)
(write '("server" "text" "Dispatched.") me->client)
(close-output-port me->client)]
;Dispatching code
[(equal? type "code")
(dispatch name type message)
(write '("server" "text" "Dispatched.") me->client)
(close-output-port me->client)]
;Else be upset
[else (write `("server" "text" ,(format "Invalid type: ~a" type)) me->client)
(close-output-port me->client)])))