Commit 6030133a authored by Peter Achten's avatar Peter Achten

no message

parent b606b8f0
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
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
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
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
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 }
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
where
receive_MT :: !(Maybe !Timeout) !*(*ch .a) !*env
-> (!TimeoutReport, !Maybe !.a,!*(*ch .a), !*env)
| ChannelEnv env
receiveUpTo :: !Int !*(*ch .a) !*env
-> (![.a], !*(*ch .a), !*env)
| ChannelEnv env
available :: !*(*ch .a) !*env
-> (!Bool, !*(*ch .a), !*env)
| ChannelEnv env
eom :: !*(*ch .a) !*env
-> (!Bool, !*(*ch .a), !*env)
| ChannelEnv