chatClient.icl 6.93 KB
Newer Older
Peter Achten's avatar
Peter Achten committed
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
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
module chatClient

//	**************************************************************************************************
//
//	This chat program runs together with the "chatServer" program
//
//	The program has been written in Clean 1.3.1 and uses the Clean Standard Object I/O library 1.1
//
//	**************************************************************************************************

import	StdEnv, StdIO, StdTCP

chatPort	:== 2000
remote		:== "martinpc.cs.kun.nl"
CR			:== '\xD'					// carriage return

::	*LS									// the ls part of th PSt
	=	{	sndChan		::	TCP_SChannel
		,	nickname	::	String
		}
::	*PState	:==	PSt LS NoState

::	NoState
	=	NoState							// The singleton data type

Start :: *World -> *World
Start world
	= startIO SDI { sndChan=undef, nickname=""} NoState initialize [ProcessWindowSize zero] world

initialize ::  PState -> PState
initialize ps
	# (dialogId, ps)	= accPIO openId ps
	  (nicknameId, ps)	= accPIO openId ps
	  (rmtsiteId, ps)	= accPIO openId ps
	  (buttonId, ps)	= accPIO openId ps

	  // prompt for chat parameters nickname and server address
	  dDef			= Dialog "Enter Chat Parameters" 
						(	EditControl "" (PixelWidth 400) 1 [ControlId nicknameId, ControlPos (Right, zero)]
						 :+:TextControl "Nickname:" [ControlPos (LeftOfPrev, zero)]
						 :+:EditControl remote (PixelWidth 400) 1 [ControlId rmtsiteId, ControlPos (Right, zero)]
						 :+:TextControl "Chat Server:" [ControlPos (LeftOfPrev, zero)]
						 :+:ButtonControl "OK" 
						 				  [ControlId buttonId,
						 				   ControlFunction (noLS1 ok (dialogId, nicknameId, rmtsiteId)),
						 				   ControlPos (Right, zero)]
						) [WindowId dialogId, WindowOk buttonId]
	# ((errReport, _), ps) = openModalDialog NoState dDef ps
	| errReport<>NoError
		= abort "abort: can't open modal dialog"
	# (_, ps) = openWindow NoState (Window "dummy" NilLS [WindowViewSize {w=100,h=30}]) ps
	= ps
  where
	ok (dialogId, nicknameId, rmtsiteId) ps
		// this function is called, when the promt dialog's ok button is pressed
		// when input parameters are fine, then it tries to connect with the server, which
		// will call "continuation" 
		# (Just dialog,ps)	= accPIO (getWindow dialogId) ps
		  controlTexts		= map (fromJust o snd) (getControlTexts [nicknameId,rmtsiteId] dialog)
		  nickname			= controlTexts !! 0
		  remoteSite		= controlTexts !! 1
		| nickname=="" || remoteSite==""
			=ps
		# ps				= lookupAndConnect remoteSite (continuation nickname remoteSite) ps
		= closeWindow dialogId ps
	continuation :: !String !String (Maybe TCP_DuplexChannel) PState -> PState
	continuation _ remoteSite Nothing ps
		= abort ("CAN'T CONNECT with "+++remoteSite)
	continuation nickname _ (Just { sChannel, rChannel }) ps
		// connection with server has been established.
		# (dialogId, ps)	= accPIO openId ps
		  (inId, ps)	= accPIO openId ps
		  (outId, ps)	= accPIO openId ps

		// build chat window & menu
		# dDef = Dialog "Chat"
						(	EditControl	"" (PixelWidth (hmm 150.0)) 5
									[	ControlId		inId
									,	ControlKeyboard	inputfilter Able (input dialogId inId)
									]
						:+:	EditControl	"" (PixelWidth (hmm 150.0)) 20
									[	ControlId		outId
									,	ControlPos		(BelowPrev,zero)
									]
						)
						[	WindowId	dialogId
						]
		  (errReport,ps)	= openDialog "" dDef ps
		| errReport<>NoError
			=	abort "chatClient could not open dialog."
		# menu		= Menu "Chat"
							(	MenuItem "Quit" [	MenuShortKey 'q'
												,	MenuFunction (noLS quit)
												]
							)	[]
		# (errReport,ps)	= openMenu NoState menu ps
		| errReport<>NoError
			=	abort "chat could not open menu."

		// first send own nickname to server, so that he can broadcast my appearance !
		# (sChannel, ps)	= send (toByteSeq nickname) sChannel ps 

		// open send notifier to eventually flush the send channels buffer 
		# (errReport, sChannel, ps)
		  				= openSendNotifier NoState
		  							(SendNotifier sChannel (noLS1 sReceiver) []) ps
		| errReport<>NoError
			=	abort "chat could not open receiver."
		
		// open receiver, which will receive the messages of other chatting people
		# (rcvId, ps)	= accPIO openId ps
		  (errReport, ps)
		  				= openReceiver (dialogId, outId)
		  					(TCP_Receiver rcvId rChannel rReceiver []) ps
		| errReport<>NoError
			=	abort "chat could not open receiver."

		= { ps & ls={ ps.ls & sndChan=sChannel } }
		
lookupAndConnect :: !String ((Maybe TCP_DuplexChannel) -> *(PState -> PState)) PState -> PState
// lookup a host via DNS, connect with that host (if possible) and call the callback function
// (which is the second parameter)
lookupAndConnect inetAddr callback ps
	= lookupIPAddress_async inetAddr lookupCBF ps
  where
    lookupCBF Nothing ps
    	= callback Nothing ps
	lookupCBF (Just inetHost) ps
		= connectTCP_async (inetHost, chatPort) connectCBF ps
	connectCBF Nothing ps
    	= callback Nothing ps
	connectCBF x=:(Just tcpDuplexChan) ps
		= callback x ps

inputfilter :: KeyboardState -> Bool
inputfilter (CharKey char (KeyDown False)  )
	= char==CR
inputfilter (SpecialKey key _ _)
	= key==EnterKey
inputfilter _
	= False
	
input dialogId inId _ (l,ps)
	= (l, setControlTextInDialog f dialogId inId ps)
  where
	f text ps=:{ls=ls=:{sndChan}, io}
		#!	(sndChan, io)	= send_NB (toByteSeq (withoutNewlines text)) sndChan io
		= ("", { ps & ls={ls & sndChan=sndChan}, io=io })
	withoutNewlines :: String -> String
	withoutNewlines str
		= toString [ ch \\ ch<-:str | isPrint ch]

sReceiver :: SendEvent PState -> PState
// the function for the receive channel's receiver
sReceiver Sendable ps=:{ls=ls=:{sndChan}, io}
	# (sndChan, io)			= flushBuffer_NB sndChan io
	= { ps & ls={ ls & sndChan=sndChan}, io=io }
sReceiver Disconnected ps
	= abort "CONNECTION DISRUPTED "
		
rReceiver :: !(ReceiveMsg ByteSeq) ((Id,Id),PState) -> ((Id,Id),PState)
// the function for the send channel's send notifier
// the local state of type (Id,Id) contains the id of the chat window and the id of the
// text control for the output
rReceiver (Received byteSeq) (ls=:(dialogId, outId), ps)
	= (ls, setControlTextInDialog f dialogId outId ps)
  where
	f oldText ps
		= (garbageCollect 1500 (oldText+++(toString byteSeq+++newlineChars)), ps)
	garbageCollect max str	// takes care, that the text in the lower edit control doesn't
		# sz = size str		// get to huge (in case of long chat sessions)
		| sz > max
			= str % (sz-max, sz-1)
		= str

rReceiver EOM _
	= abort "CONNECTION DISRUPTED "

quit ps=:{ls=ls=:{sndChan}, io}
	# io	= closeChannel sndChan io
	= closeProcess { ps & ls={ls & sndChan=undef}, io=io }

setControlTextInDialog :: (String PState -> (String, PState)) Id Id PState -> PState
// performs a state transition on the text of an edit control with id <controlId> in window <dialogId>
setControlTextInDialog f dialogId controlId ps
	# (Just wState, ps) = accPIO (getWindow dialogId) ps
	  l					= getControlTexts [controlId] wState
	  oldText			= hd (map (fromJust o snd) l)
	  (newText, ps)		= f oldText ps
	  ps				= appPIO (setControlText controlId newText) ps
	= appPIO (setEditControlCursor controlId (size newText)) ps