no message

ObjectIO/Tcp Examples/chat/chatClient.icl

+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
+	

ObjectIO/Tcp Examples/chat/chatServer.icl

+module chatServer
+
+//  ********************************************************************************
+//  Clean tutorial example program.
+//  
+//  This program demonstrates the usage of the selectChannel function
+//
+//  ********************************************************************************
+
+import  StdEnv, StdTCPChannels, StdMaybe
+
+chatPort	:==	2000
+
+::	*ChanInfo
+	=	{	sndChan		::	TCP_SChannel
+		,	rcvChan		::	TCP_RChannel
+		,	nickname	::	String
+		}
+
+Start world
+	# (ok, mbListener, world)	= openTCP_Listener chatPort world
+	| not ok
+		= abort ("chatServer: can't listen on port "+++toString chatPort)
+	# (console, world)		= stdio world
+	  console	= fwrites "This server program waits until a client program " console
+	  console	= fwrites "tries to connect.\n" console
+	= loop (fromJust mbListener) [] console world
+
+
+loop :: !TCP_Listener ![ChanInfo] !*File !*World -> *World
+loop listener channels console world
+	# (sChans, rChans, nicknames)
+				= unzip3 channels
+	  glue		= (TCP_Listeners [listener]) :^: (TCP_RChannels rChans)
+	  ([(who,what):_],glue, _, world)
+				= selectChannel_MT Nothing glue Void world
+	  (TCP_Listeners [listener:_]) :^: (TCP_RChannels rChans)
+	  			= glue
+	  channels	= zip3 sChans rChans nicknames
+		
+	// case 1: someone wants to join the chatroom
+		
+	| who==0
+		# (tReport, mbNewMember, listener, world)
+							= receive_MT (Just 0) listener world
+		| tReport<>TR_Success            // the potential new member changed it's mind
+			= loop listener channels console world
+		# (_,{sChannel,rChannel})	= fromJust mbNewMember
+		  (byteSeq, rChannel, world)
+		  					= receive rChannel world
+		  nickname			= toString byteSeq
+		  message			= "*** "+++nickname+++" joined the group."
+		  console			= fwrites (message+++"\n") console
+		  channel			= { sndChan=sChannel, rcvChan=rChannel, nickname=nickname }
+		  channels			= [channel:channels]
+		  (channels, world)	= broadcastString message channels [] world
+		| nickname % (0,3)=="quit"
+			= quit listener channels world
+		= loop listener channels console world
+
+	// case 2: somebody has something to say
+
+	| what==SR_Available
+		# (channel=:{rcvChan, nickname}, channels)
+		  						= selectList (who-1) channels
+		  (byteSeq, rcvChan, world)
+		  						= receive rcvChan world
+		  message				= toString byteSeq
+		  channels				= channels++[{channel & rcvChan=rcvChan}]
+		  (channels, world)		= broadcastString	(nickname+++": "+++message)
+		  											channels [] world
+		= loop listener channels (fwrites message console)  world
+
+	// case 3: somebody leaves the group
+	
+	| what==SR_EOM
+	# ({sndChan, rcvChan, nickname}, channels)
+		  						= selectList (who-1) channels
+	  message					= "*** "+++nickname+++" left the group"
+	  console					= fwrites (message+++"\n") console
+	  (channels, world)			= broadcastString message channels [] world
+	  world						= seq [closeChannel sndChan, closeRChannel rcvChan] world
+	= loop listener channels console  world
+
+broadcastString :: !String ![ChanInfo] ![ChanInfo] !*World -> ([ChanInfo],!*World)
+broadcastString string [] akku world
+	= (u_reverse akku, world)
+broadcastString string [channel=:{sndChan}:channels] akku world
+	# (sndChan, world)		= send (toByteSeq string) sndChan world
+	= broadcastString string channels [{channel & sndChan=sndChan}:akku] world
+
+selectList :: !Int [.a] -> (!.a,![.a])
+selectList n l
+	# (left, [element:right])	= splitAt n l
+	= (element, left++right)
+
+quit listener channels world
+	# world = closeRChannel listener world
+	= closeChannels channels world
+
+closeChannels [] world
+	= world
+closeChannels [{sndChan, rcvChan}: channels] world
+	# world	= seq [closeChannel sndChan, closeRChannel rcvChan] world
+	= closeChannels channels world
+
+unzip3 :: ![!ChanInfo] -> (![TCP_SChannel], ![!TCP_RChannel], ![String])
+unzip3 [] = ([],[],[])
+unzip3 [{sndChan, rcvChan, nickname}:t]
+	# (a,b,c) = unzip3 t
+	= ([sndChan:a], [rcvChan:b], [nickname:c])
+
+zip3 :: ![TCP_SChannel] ![!TCP_RChannel] ![String] -> [!ChanInfo]
+zip3 [] [] [] = []
+zip3 [sndChan:a] [rcvChan:b] [nickname:c]
+	= [{sndChan=sndChan, rcvChan=rcvChan, nickname=nickname} : zip3 a b c]
+
+u_reverse list = reverse_ list []
+where 
+	reverse_ [hd:tl] list	= reverse_ tl [hd:list]
+	reverse_ [] list		= list

ObjectIO/Tcp Examples/downloadHTTP/downloadHTTP.icl

+module downloadHTTP
+
+//	**************************************************************************************************
+//
+//	A program that uses HTTP to download the beginning of a HTML page
+//
+//	The program has been written in Clean 1.3.1 and uses the Clean Standard Object I/O library 1.1
+//	
+//	**************************************************************************************************
+import StdIO
+import	StdEnv, StdTCP, StdMaybe
+from	StdSystem import ticksPerSecond
+
+server	:== "www.cs.kun.nl"
+path	:== "/~clean/"		// the Clean homepage
+
+httpCommand	= "GET "+++path+++" HTTP/1.0\xD\xA\xD\xA"
+port	:== 80
+
+Start world
+	#	(console, world)			= stdio world
+
+  // get the IP address of the server
+
+		(mbIPAddr, world)			= lookupIPAddress server world
+	|	isNothing mbIPAddr
+		#	console					= fwrites (server+++" not found\n") console
+		= fclose console world
+
+  // connect
+
+	#	(tReport, mbDuplexChan, world)
+									= connectTCP_MT (Just (15*ticksPerSecond))
+									                (fromJust mbIPAddr, port) world
+	|	tReport<>TR_Success
+		#!	console 				= fwrites (   server+++" does not respond on port "
+											   +++toString port+++"\n") console
+		= fclose console world
+	#!	console 					= fwrites (server+++" responded on port "+++toString port+++"\n")
+											  console
+		{ sChannel=sc, rChannel=rc }= fromJust mbDuplexChan
+//	**************************************************************************************************
+
+  // send http command
+
+		(sc, world)					= send (toByteSeq httpCommand) sc world
+
+  // receive answer
+
+		(tReport, mbBs, rc, world)	= receive_MT (Just (20*ticksPerSecond)) rc world
+		console	= case tReport of
+					TR_Success		-> fwrites (toString (fromJust mbBs)) console
+					_				-> fwrites (server+++" does not send anything (timeout expired)")
+											   console
+
+  // close
+
+		world						= closeRChannel rc world
+		world						= closeChannel sc world
+	= fclose console world
+
+

ObjectIO/Tcp Examples/echo/echoClient.icl

+module echoClient
+
+//	**************************************************************************************************
+//  Clean tutorial example program.
+//
+//	A program to use together with echoServer
+//
+//	**************************************************************************************************
+
+import	StdEnv, StdTCP, StdMaybe
+from	StdSystem import ticksPerSecond
+
+echoPort	:== 7
+
+sendMessage	:==	"HELLO"
+
+Start world
+	#	(console, world)			= stdio world
+
+  // get the IP address of the server
+		console						= fwrites "enter address of echo server:" console
+		(line, console)				= freadline console
+		server						= line % (0, (size line)-2)
+		(mbIPAddr, world)			= lookupIPAddress server world
+	|	isNothing mbIPAddr
+		#	console					= fwrites (server+++" not found\n") console
+		= end console world
+
+  // connect
+
+	#	(tReport, mbDuplexChan, world)
+									= connectTCP_MT (Just (15*ticksPerSecond))
+												    (fromJust mbIPAddr, echoPort) world
+	|	tReport<>TR_Success
+		#!	console 				= fwrites (   server+++" does not respond on port "
+											   +++toString echoPort+++"\n") console
+		= end console world
+	#!	console 					= fwrites	(server+++" responded on port "+++toString echoPort)
+												console
+		{ sChannel=sc, rChannel=rc }= fromJust mbDuplexChan
+
+  // send something
+
+		(sc, world)					= send (toByteSeq sendMessage) sc world
+
+  // receive answer
+
+		(bs, rc, world)				= receive rc world
+		console						= fwrites (" with \""+++toString bs+++"\".\n") console
+
+  // close
+
+		world						= closeRChannel rc world
+		world						= closeChannel sc world
+	= end console world
+
+end :: !*File !*World -> *World
+end console world
+	#!	console		= fwrites "press return to exit program" console
+		(_, console)= freadline console
+		(_,world)	= fclose console world
+	= world
\ No newline at end of file

ObjectIO/Tcp Examples/echo/echoServer.icl

+module echoServer
+
+//  ********************************************************************************
+//  Clean tutorial example program.
+//  
+//  This program demonstrates the usage of functions for event driven TCP.
+//	It listens on port 7, accepts a connection and echoes the input
+//
+//  ********************************************************************************
+
+import  StdEnv, StdTCP, StdIO
+
+echoPort	:== 7
+
+::	*PState	:== PSt TCP_DuplexChannel Bool
+//	The Boolean value stores, whether EOM happened on the receive channel.
+
+Start world
+	# (ok, mbListener, world)	= openTCP_Listener echoPort world
+	| not ok
+		= abort ("chatServer: can't listen on port "+++toString echoPort)
+	#!(console, world)		= stdio world
+	  console	= fwrites "This server program waits until a client program " console
+	  console	= fwrites "tries to connect.\n" console
+	  (_,world)	= fclose console world
+	  ((_,duplexChan), listener, world)
+	  							= receive (fromJust mbListener) world
+	  world						= closeRChannel listener world
+	= startIO NDI duplexChan False initialize [] world
+
+///////////////////////////////////////////////////////////
+////	initialize - the function to initialze the PSt ////
+///////////////////////////////////////////////////////////
+
+initialize	:: PState -> PState
+initialize pSt=:{ ls={rChannel,sChannel}, io }
+	# (tcpRcvId, io)	= openId io
+	  pSt 				= { pSt & ls = { rChannel=undef, sChannel=undef }, io=io }
+
+  // open a receiver for the receive channel
+
+	  (errReport1, pSt)	= openReceiver tcpRcvId 
+	  								  (TCP_Receiver tcpRcvId rChannel rcvFun []) pSt
+
+  // open a receiver for the send channel
+
+	  (errReport2, sChannel, pSt)
+						= openSendNotifier tcpRcvId 
+										   (SendNotifier sChannel sndFun []) pSt
+	| errReport1<>NoError || errReport2<>NoError
+		= abort "error: can't open receiver"
+	= { pSt & ls={ rChannel=undef, sChannel=sChannel } }
+
+/////////////////////////////////////////////////////////////////////////////
+////	rcvFun - the callback function for the receive channels receiver ////
+/////////////////////////////////////////////////////////////////////////////
+
+rcvFun :: (ReceiveMsg ByteSeq) (Id,PState) -> (Id,PState)
+rcvFun (Received byteSeq) (tcpRcvId, pSt=:{ ls=ls=:{sChannel}, io})
+	# (sChannel, io)		= send_NB byteSeq sChannel io
+	  (buffSize,sChannel)	= bufferSize sChannel
+
+  //  disable this receiver, if the send channel is full
+
+	  io = case buffSize of
+	  		0 -> io
+	  		_ -> disableReceivers [tcpRcvId] io
+	= (tcpRcvId, { pSt & ls={ ls & sChannel=sChannel}, io=io })
+rcvFun EOM (tcpRcvId, pSt=:{ ls=ls=:{sChannel}, io})
+	# (buffSize,sChannel)	= bufferSize sChannel
+	  pSt	= { pSt & ls  = { ls & sChannel=sChannel}, ps=True, io=io }
+
+  //  close program only, if all data in the send channels ineternal buffer has been
+  //  sent
+
+	  pSt = case buffSize of
+	  			0 	-> closeProcess (close pSt)
+				_	-> pSt
+	= (tcpRcvId, pSt)
+
+//////////////////////////////////////////////////////////////////////////
+////	sndFun - the callback function for the send channels receiver ////
+//////////////////////////////////////////////////////////////////////////
+
+sndFun :: SendEvent (Id,PState) -> (Id,PState)
+sndFun Sendable (tcpRcvId, pSt=:{ ls=ls=:{sChannel}, ps=eomHappened ,io})
+	# (sChannel, io)		= flushBuffer_NB sChannel io
+	  (buffSize,sChannel)	= bufferSize sChannel
+	  pSt	= { pSt & ls  = { ls & sChannel=sChannel}, io=io }
+
+  //  enable the receive channel's receiver again, if the send channel is still
+  //  sendable
+
+	  pSt = case (buffSize,eomHappened) of
+	  			(0, False)	-> { pSt & io = enableReceivers [tcpRcvId] pSt.io }
+	  			(0, True )	-> close pSt
+				_			-> pSt
+	= (tcpRcvId, pSt)
+sndFun Disconnected (ls, pSt)
+	= (ls, closeProcess pSt)
+
+close	::	PState -> PState
+close pSt=:{ls=ls=:{sChannel}, io}
+	#!	io				= closeChannel sChannel io
+	= { pSt & ls={ ls & sChannel=undef}, io=io }

ObjectIO/Tcp/StdChannels.dcl

+definition module StdChannels
+
+//	********************************************************************************
+//	Clean Standard Object I/O library, version 1.2
+//	
+//	StdChannels defines operations on channels
+//	********************************************************************************
+
+from	StdMaybe		import	Maybe
+from	StdOverloaded	import	==, toString
+from	channelenv		import	ChannelEnv
+
+instance ChannelEnv World
+// other instances are IOSt & PSt (see StdPSt)
+
+///////////////////////////////// receive channels /////////////////////////////////
+
+class Receive ch