Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
clean-and-itasks
clean-libraries
Commits
b7959bd8
Commit
b7959bd8
authored
Sep 07, 2020
by
John van Groningen
Browse files
Merge branch 'new-maybes-in-TCPIP' into 'master'
Use strict maybe types in TCPIP library See merge request
!11
parents
db2c7cb1
fb773dae
Changes
15
Hide whitespace changes
Inline
Side-by-side
Libraries/ObjectIO/ObjectIO/OS Linux/osevent.icl
View file @
b7959bd8
implementation
module
osevent
import
StdBool
,
StdList
,
StdMisc
,
StdTuple
import
StdBool
,
StdList
,
StdMaybe
,
StdMisc
,
StdTuple
import
clCrossCall_12
,
ostime
,
ostoolbox
,
ostypes
from
commondef
import
hdtl
,
fatalError
from
StdMaybe
import
::
Maybe
(..)
...
...
Libraries/ObjectIO/ObjectIO/OS Mac Carbon/osevent.icl
View file @
b7959bd8
implementation
module
osevent
import
StdInt
,
StdBool
,
StdList
,
StdTuple
import
StdInt
,
StdBool
,
StdList
,
StdMaybe
,
StdTuple
import
events
,
desk
,
pointer
import
StdClass
,
StdMisc
import
code
from
"cTCP."
...
...
Libraries/TCPIP/Linux_C/ostcp.dcl
View file @
b7959bd8
...
...
@@ -7,7 +7,6 @@ definition module ostcp
// Modified: 15 October 2001 for Clean 2.0 (Peter Achten)
// ********************************************************************************
import
StdMaybe
import
TCPDef
from
TCPChannelClass
import
::
Timeout
import
tcp
...
...
@@ -27,5 +26,5 @@ os_connectTCP_sync :: !Int !(!Bool,!Int) !(!Int,!Int) !*env
// not block: (referencecount=1, hasSNotif=False, hasRNotif=True)
// if timeout or error occurs, then resources (endpoint and dictionary entry) will be removed
getMbStopTime
::
!(
Maybe
Timeout
)
!*
env
->
(!(!
Bool
,
!
Int
),
!*
env
)
|
ChannelEnv
env
getMbStopTime
::
!(
?
Timeout
)
!*
env
->
(!(!
Bool
,
!
Int
),
!*
env
)
|
ChannelEnv
env
tcp_getcurrenttick
::
!*
World
->
(!
Int
,
!*
World
)
Libraries/TCPIP/Linux_C/ostcp.icl
View file @
b7959bd8
implementation
module
ostcp
import
StdInt
,
StdTuple
import
StdMaybe
import
TCPDef
,
TCPChannelClass
import
tcp
...
...
@@ -91,10 +90,10 @@ os_connectTCP_sync32 onlyForMac time addr e
ccall
os_connectTCP_syncC
"IIIII:VIII:A"
}
getMbStopTime
::
!(
Maybe
Timeout
)
!*
env
->
(!(!
Bool
,
!
Int
),
!*
env
)
|
ChannelEnv
env
getMbStopTime
No
thing
env
getMbStopTime
::
!(
?
Timeout
)
!*
env
->
(!(!
Bool
,
!
Int
),
!*
env
)
|
ChannelEnv
env
getMbStopTime
?
No
ne
env
=((
False
,
0
),
env
)
getMbStopTime
(
Just
timeout
)
env
getMbStopTime
(
?
Just
timeout
)
env
#
(
now
,
env
)
=
channel_env_get_current_tick
env
=
((
True
,
timeout
+
now
),
env
)
...
...
Libraries/TCPIP/ObjectIO/StdEventTCP.icl
View file @
b7959bd8
...
...
@@ -81,11 +81,11 @@ instance Receivers TCP_ListenerReceiver where
=
open_RChan_or_Listener
close_listener
ls
id
rAttributes
endpointRef
0
(
handleConnectRequest
f
)
ListenerReceiver
pSt
where
handleConnectRequest
f
(
IE_CONNECTREQUEST
,
endpointRef
,_)
(
ls
,
ps
=:{
io
})
#
(_,
mbHostDuplexChan
,_,
io
)
=
receive_MT
(
Just
0
)
(
pack_tcplistener
endpointRef
)
io
#
(_,
mbHostDuplexChan
,_,
io
)
=
receive_MT
(
?
Just
0
)
(
pack_tcplistener
endpointRef
)
io
=
case
mbHostDuplexChan
of
No
thing
?
No
ne
->
(
ls
,
{
ps
&
io
=
io
})
Just
hostDuplexChan
?
Just
hostDuplexChan
->
f
(
Received
hostDuplexChan
)
(
ls
,
{
ps
&
io
=
io
})
getReceiverType
_
...
...
@@ -178,7 +178,7 @@ where
handleReceiveEvent
::
!
Id
!
Int
((
ReceiveMsg
ByteSeq
)
->
*(.
ls
,
PSt
.
a
)
->
*(.
ls
,
PSt
.
a
))
(!
InetEvent
,
!
EndpointRef
,
!
Int
)
*(.
ls
,
PSt
.
a
)
->
*(.
ls
,
PSt
.
a
)
handleReceiveEvent
_
maxSize
f
(
IE_RECEIVED
,
endpointRef
,_)
(
ls
,
ps
=:{
io
})
#
(_,
mbTCPData
,_,
io
)
=
receive_MT
(
Just
0
)
(
pack_tcprchan
(
endpointRef
,
maxSize
))
io
#
(_,
mbTCPData
,_,
io
)
=
receive_MT
(
?
Just
0
)
(
pack_tcprchan
(
endpointRef
,
maxSize
))
io
|
isNothing
mbTCPData
=
(
ls
,{
ps
&
io
=
io
})
=
f
(
Received
(
fromJust
mbTCPData
))
(
ls
,{
ps
&
io
=
io
})
...
...
Libraries/TCPIP/ObjectIO/StdTCPChannels.icl
View file @
b7959bd8
...
...
@@ -48,7 +48,7 @@ instance SelectReceive Void
accRChannels
_
void
=
([],
void
)
getRState
_
void
env
=
(
No
thing
,
void
,
env
)
=
(
?
No
ne
,
void
,
env
)
instance
getNrOfChannels
(:^:
*
x
*
y
)
|
getNrOfChannels
x
&
getNrOfChannels
y
where
...
...
Libraries/TCPIP/TCPChannelClass.dcl
View file @
b7959bd8
...
...
@@ -8,7 +8,6 @@ definition module TCPChannelClass
// Modified: 15 October 2001 for Clean 2.0 (Peter Achten)
// ********************************************************************************
from
StdMaybe
import
::
Maybe
from
StdOverloaded
import
class
toString
,
class
==
from
tcp
import
class
ChannelEnv
...
...
@@ -19,11 +18,11 @@ instance ChannelEnv World
// ********************************************************************************
class
Receive
ch
where
receive_MT
::
!(
Maybe
Timeout
)
!*(
ch
.
a
)
!*
env
->
(!
TimeoutReport
,
!
Maybe
.
a
,
!*(
ch
.
a
),
!*
env
)
receive_MT
::
!(
?
Timeout
)
!*(
ch
.
a
)
!*
env
->
(!
TimeoutReport
,
!
?
.
a
,
!*(
ch
.
a
),
!*
env
)
|
ChannelEnv
env
receiveUpTo
::
!
Int
!*(
ch
.
a
)
!*
env
->
(![.
a
],
!*(
ch
.
a
),
!*
env
)
receiveUpTo
::
!
Int
!*(
ch
.
a
)
!*
env
->
(![.
a
],
!*(
ch
.
a
),
!*
env
)
|
ChannelEnv
env
available
::
!*(
ch
.
a
)
!*
env
->
(!
Bool
,
!*(
ch
.
a
),
!*
env
)
...
...
@@ -54,24 +53,24 @@ class closeRChannel ch :: !*(ch .a) !*env -> *env | ChannelEnv env
// ********************************************************************************
class
Send
ch
where
send_MT
::
!(
Maybe
Timeout
)
!.
a
!*(
ch
.
a
)
!*
env
send_MT
::
!(
?
Timeout
)
!.
a
!*(
ch
.
a
)
!*
env
->
(!
TimeoutReport
,
!
Int
,
!*(
ch
.
a
),
!*
env
)
|
ChannelEnv
env
nsend_MT
::
!(
Maybe
Timeout
)
![.
a
]
!*(
ch
.
a
)
!*
env
|
ChannelEnv
env
nsend_MT
::
!(
?
Timeout
)
![.
a
]
!*(
ch
.
a
)
!*
env
->
(!
TimeoutReport
,
!
Int
,
!*(
ch
.
a
),
!*
env
)
|
ChannelEnv
env
flushBuffer_MT
::
!(
Maybe
Timeout
)
!*(
ch
.
a
)
!*
env
|
ChannelEnv
env
flushBuffer_MT
::
!(
?
Timeout
)
!*(
ch
.
a
)
!*
env
->
(!
TimeoutReport
,
!
Int
,
!*(
ch
.
a
),
!*
env
)
|
ChannelEnv
env
closeChannel_MT
::
!(
Maybe
Timeout
)
!*(
ch
.
a
)
!*
env
|
ChannelEnv
env
closeChannel_MT
::
!(
?
Timeout
)
!*(
ch
.
a
)
!*
env
->
(!
TimeoutReport
,
!
Int
,
!*
env
)
|
ChannelEnv
env
|
ChannelEnv
env
abortConnection
::
!*(
ch
.
a
)
!*
env
->
*
env
|
ChannelEnv
env
|
ChannelEnv
env
disconnected
::
!*(
ch
.
a
)
!*
env
->
(!
Bool
,
!*(
ch
.
a
),
!*
env
)
|
ChannelEnv
env
|
ChannelEnv
env
bufferSize
::
!*(
ch
.
a
)
->
(!
Int
,
!*(
ch
.
a
))
/* send_MT mbTimeout a ch env
...
...
@@ -129,7 +128,7 @@ instance toString TimeoutReport
// derived functions
// ********************************************************************************
nreceive_MT
::
!(
Maybe
Timeout
)
!
Int
!*(
ch
.
a
)
!*
env
nreceive_MT
::
!(
?
Timeout
)
!
Int
!*(
ch
.
a
)
!*
env
->
(!
TimeoutReport
,
![.
a
],!*(
ch
.
a
),!*
env
)
|
Receive
ch
&
ChannelEnv
env
/* nreceive_MT mbTimeout n ch env
...
...
Libraries/TCPIP/TCPChannelClass.icl
View file @
b7959bd8
...
...
@@ -17,11 +17,11 @@ instance ChannelEnv World
///////////////////////////////// receive channels /////////////////////////////////
class
Receive
ch
where
receive_MT
::
!(
Maybe
Timeout
)
!*(
ch
.
a
)
!*
env
->
(!
TimeoutReport
,
!
Maybe
.
a
,
!*(
ch
.
a
),
!*
env
)
receive_MT
::
!(
?
Timeout
)
!*(
ch
.
a
)
!*
env
->
(!
TimeoutReport
,
!
?
.
a
,
!*(
ch
.
a
),
!*
env
)
|
ChannelEnv
env
receiveUpTo
::
!
Int
!*(
ch
.
a
)
!*
env
->
(![.
a
],
!*(
ch
.
a
),
!*
env
)
receiveUpTo
::
!
Int
!*(
ch
.
a
)
!*
env
->
(![.
a
],
!*(
ch
.
a
),
!*
env
)
|
ChannelEnv
env
available
::
!*(
ch
.
a
)
!*
env
->
(!
Bool
,
!*(
ch
.
a
),
!*
env
)
...
...
@@ -36,26 +36,26 @@ class closeRChannel ch :: !*(ch .a) !*env -> *env | ChannelEnv env
class
Send
ch
where
send_MT
::
!(
Maybe
Timeout
)
!.
a
!*(
ch
.
a
)
!*
env
->
(!
TimeoutReport
,
!
Int
,
!*(
ch
.
a
),
!*
env
)
|
ChannelEnv
env
nsend_MT
::
!(
Maybe
Timeout
)
![.
a
]
!*(
ch
.
a
)
!*
env
->
(!
TimeoutReport
,
!
Int
,
!*(
ch
.
a
),
!*
env
)
|
ChannelEnv
env
flushBuffer_MT
::
!(
Maybe
Timeout
)
!*(
ch
.
a
)
!*
env
->
(!
TimeoutReport
,
!
Int
,
!*(
ch
.
a
),
!*
env
)
|
ChannelEnv
env
closeChannel_MT
::
!(
Maybe
Timeout
)
!*(
ch
.
a
)
!*
env
->
(!
TimeoutReport
,
!
Int
,
!*
env
)
|
ChannelEnv
env
abortConnection
::
!*(
ch
.
a
)
!*
env
->
*
env
|
ChannelEnv
env
disconnected
::
!*(
ch
.
a
)
!*
env
->
(!
Bool
,
!*(
ch
.
a
),
!*
env
)
|
ChannelEnv
env
bufferSize
::
!*(
ch
.
a
)
->
(!
Int
,
!*(
ch
.
a
))
send_MT
::
!(
?
Timeout
)
!.
a
!*(
ch
.
a
)
!*
env
->
(!
TimeoutReport
,
!
Int
,
!*(
ch
.
a
),
!*
env
)
|
ChannelEnv
env
nsend_MT
::
!(
?
Timeout
)
![.
a
]
!*(
ch
.
a
)
!*
env
->
(!
TimeoutReport
,
!
Int
,
!*(
ch
.
a
),
!*
env
)
|
ChannelEnv
env
flushBuffer_MT
::
!(
?
Timeout
)
!*(
ch
.
a
)
!*
env
->
(!
TimeoutReport
,
!
Int
,
!*(
ch
.
a
),
!*
env
)
|
ChannelEnv
env
closeChannel_MT
::
!(
?
Timeout
)
!*(
ch
.
a
)
!*
env
->
(!
TimeoutReport
,
!
Int
,
!*
env
)
|
ChannelEnv
env
abortConnection
::
!*(
ch
.
a
)
!*
env
->
*
env
|
ChannelEnv
env
disconnected
::
!*(
ch
.
a
)
!*
env
->
(!
Bool
,
!*(
ch
.
a
),
!*
env
)
|
ChannelEnv
env
bufferSize
::
!*(
ch
.
a
)
->
(!
Int
,
!*(
ch
.
a
))
class
MaxSize
ch
where
...
...
@@ -92,9 +92,9 @@ instance toString TimeoutReport
/////////////////// derived functions ////////////////////////////////////////////////////
nreceive_MT
::
!(
Maybe
Timeout
)
!
Int
!*(
ch
.
a
)
!*
env
->
(!
TimeoutReport
,
![.
a
],
!*(
ch
.
a
),
!*
env
)
|
Receive
ch
&
ChannelEnv
env
nreceive_MT
::
!(
?
Timeout
)
!
Int
!*(
ch
.
a
)
!*
env
->
(!
TimeoutReport
,
![.
a
],
!*(
ch
.
a
),
!*
env
)
|
Receive
ch
&
ChannelEnv
env
nreceive_MT
mbTimeout
n
ch
env
// #! (before, env) = getCurrentTick env
#!
(
before
,
env
)
=
channel_env_get_current_tick
env
...
...
@@ -112,8 +112,8 @@ nreceive_MT mbTimeout n ch env
// = nreceive_MT (mbSubtract mbTimeout (tickDifference after before)) (n-length-1) ch env
=
nreceive_MT
(
mbSubtract
mbTimeout
(
after
-
before
))
(
n
-
length
-1
)
ch
env
where
mbSubtract
No
thing
_
=
No
thing
mbSubtract
(
Just
timeout
)
i
=
Just
(
timeout
-
i
)
mbSubtract
?
No
ne
_
=
?
No
ne
mbSubtract
(
?
Just
timeout
)
i
=
?
Just
(
timeout
-
i
)
u_reverse
::![.
a
]
->
[.
a
]
u_reverse
list
=
reverse_
list
[]
...
...
@@ -134,7 +134,7 @@ u_length l
receive
::
!*(
ch
.
a
)
!*
env
->
(!.
a
,
!*(
ch
.
a
),
!*
env
)
|
ChannelEnv
env
&
Receive
ch
receive
ch
env
#!
(
timeoutReport
,
mbMessage
,
ch
,
env
)
=
receive_MT
No
thing
ch
env
#!
(
timeoutReport
,
mbMessage
,
ch
,
env
)
=
receive_MT
?
No
ne
ch
env
|
timeoutReport
==
TR_NoSuccess
#!
(
isEom
,
ch
,
env
)
=
eom
ch
env
|
isEom
...
...
@@ -145,7 +145,7 @@ receive ch env
nreceive
::
!
Int
!*(
ch
.
a
)
!*
env
->
(![.
a
],
!*(
ch
.
a
),
!*
env
)
|
ChannelEnv
env
&
Receive
ch
nreceive
n
ch
env
#!
(
timeoutReport
,
l
,
ch
,
env
)
=
nreceive_MT
No
thing
n
ch
env
#!
(
timeoutReport
,
l
,
ch
,
env
)
=
nreceive_MT
?
No
ne
n
ch
env
|
timeoutReport
==
TR_NoSuccess
#!
(
isEom
,
ch
,
env
)
=
eom
ch
env
|
isEom
...
...
@@ -156,29 +156,29 @@ nreceive n ch env
send
::
!.
a
!*(
ch
.
a
)
!*
env
->
(!*(
ch
.
a
),
!*
env
)
|
ChannelEnv
env
&
Send
ch
send
msg
ch
env
#!
(_,_,
ch
,
env
)
=
send_MT
No
thing
msg
ch
env
#!
(_,_,
ch
,
env
)
=
send_MT
?
No
ne
msg
ch
env
=
(
ch
,
env
)
closeChannel
::
!*(
ch
.
a
)
!*
env
->
*
env
|
ChannelEnv
env
&
Send
ch
closeChannel
ch
env
#!
(_,_,
env
)
=
closeChannel_MT
No
thing
ch
env
#!
(_,_,
env
)
=
closeChannel_MT
?
No
ne
ch
env
=
env
nsend
::
![.
a
]
!*(
ch
.
a
)
!*
env
->
(!*(
ch
.
a
),
!*
env
)
|
ChannelEnv
env
&
Send
ch
nsend
msg
ch
env
#!
(_,_,
ch
,
env
)
=
nsend_MT
No
thing
msg
ch
env
#!
(_,_,
ch
,
env
)
=
nsend_MT
?
No
ne
msg
ch
env
=
(
ch
,
env
)
send_NB
::
!.
a
!*(
ch
.
a
)
!*
env
->
(!*(
ch
.
a
),
!*
env
)
|
ChannelEnv
env
&
Send
ch
send_NB
msg
ch
env
#!
(_,_,
ch
,
env
)
=
send_MT
(
Just
0
)
msg
ch
env
#!
(_,_,
ch
,
env
)
=
send_MT
(
?
Just
0
)
msg
ch
env
=
(
ch
,
env
)
flushBuffer_NB
::
!*(
ch
.
a
)
!*
env
->
(!*(
ch
.
a
),
!*
env
)
|
ChannelEnv
env
&
Send
ch
flushBuffer_NB
ch
env
#!
(_,_,
ch
,
env
)
=
flushBuffer_MT
(
Just
0
)
ch
env
#!
(_,_,
ch
,
env
)
=
flushBuffer_MT
(
?
Just
0
)
ch
env
=
(
ch
,
env
)
Libraries/TCPIP/TCPChannels.dcl
View file @
b7959bd8
...
...
@@ -67,13 +67,13 @@ instance Send TCP_SCharStream_
// ********************************************************************************
lookupIPAddress
::
!
String
!*
env
->
(!
Maybe
IPAddress
,
!*
env
)
->
(!
?
IPAddress
,
!*
env
)
|
ChannelEnv
env
connectTCP_MT
::
!(
Maybe
Timeout
)
!(!
IPAddress
,!
Port
)
!*
env
->
(!
TimeoutReport
,
!
Maybe
TCP_DuplexChannel
,
!*
env
)
connectTCP_MT
::
!(
?
Timeout
)
!(!
IPAddress
,!
Port
)
!*
env
->
(!
TimeoutReport
,
!
?
TCP_DuplexChannel
,
!*
env
)
|
ChannelEnv
env
openTCP_Listener
::
!
Port
!*
env
->
(!
Bool
,
!
Maybe
TCP_Listener
,
!*
env
)
->
(!
Bool
,
!
?
TCP_Listener
,
!*
env
)
|
ChannelEnv
env
tcpPossible
::
!*
env
->
(!
Bool
,
!*
env
)
...
...
@@ -93,7 +93,7 @@ tcpPossible :: !*env
// multiplexing
// ********************************************************************************
selectChannel_MT
::
!(
Maybe
Timeout
)
!*
r_channels
!*
s_channels
!*
env
selectChannel_MT
::
!(
?
Timeout
)
!*
r_channels
!*
s_channels
!*
env
->
(![(
Int
,
SelectResult
)],!*
r_channels
,!*
s_channels
,!*
env
)
|
SelectReceive
r_channels
&
SelectSend
s_channels
&
ChannelEnv
env
/* selectChannel_MT mbTimeout r_channels s_channels world
...
...
@@ -118,7 +118,7 @@ class SelectReceive channels where
accRChannels
::
(
PrimitiveRChannel
->
(
x
,
PrimitiveRChannel
))
!*
channels
->
(![
x
],
!*
channels
)
getRState
::
!
Int
!*
channels
!*
env
->
(!
Maybe
SelectResult
,
!*
channels
,
!*
env
)
|
ChannelEnv
env
->
(!
?
SelectResult
,
!*
channels
,
!*
env
)
|
ChannelEnv
env
/* accRChannels f channels
applies a function on each channel in channels and returns a list which
contains the result for each application.
...
...
Libraries/TCPIP/TCPChannels.icl
View file @
b7959bd8
implementation
module
TCPChannels
import
StdEnv
import
StdEnv
,
StdMaybe
from
StdFunc
import
seq
import
TCPDef
,
TCPChannelClass
import
tcp
,
ostcp
,
tcp_bytestreams
...
...
@@ -28,7 +28,7 @@ instance Receive TCP_Listener_
receiveUpToGeneral
akku
max
ch
env
|
max
<=
0
=
(
u_reverse
akku
,
ch
,
env
)
#!
(
tReport
,
mbData
,
ch
,
env
)
=
receive_MT
(
Just
0
)
ch
env
#!
(
tReport
,
mbData
,
ch
,
env
)
=
receive_MT
(
?
Just
0
)
ch
env
|
tReport
<>
TR_Success
=
(
u_reverse
akku
,
ch
,
env
)
=
receiveUpToGeneral
[
fromJust
mbData
:
akku
]
(
dec
max
)
ch
env
...
...
@@ -39,11 +39,11 @@ instance closeRChannel TCP_Listener_
#
endpointRef
=
unpack_tcplistener
ch
=
close_listener
endpointRef
env
receive_mb_Listener
::
!(
Maybe
Timeout
)
!
EndpointRef
!*
env
->
(!
TimeoutReport
,
!
Maybe
(!
IPAddress
,
!
TCP_DuplexChannel
),
!*
env
)
|
ChannelEnv
env
receive_mb_Listener
::
!(
?
Timeout
)
!
EndpointRef
!*
env
->
(!
TimeoutReport
,
!
?
(!
IPAddress
,
!
TCP_DuplexChannel
),
!*
env
)
|
ChannelEnv
env
receive_mb_Listener
mbTimeout
endpointRef
env
|
isJust
mbTimeout
&&
(
fromJust
mbTimeout
)<
0
=
(
TR_Expired
,
No
thing
,
env
)
=
(
TR_Expired
,
?
No
ne
,
env
)
#!
(
cReqAvail
,
env
)
=
os_connectrequestavailable
endpointRef
env
=
if
cReqAvail
(
accept
endpointRef
env
)
(
wait
endpointRef
env
)
where
...
...
@@ -52,15 +52,15 @@ receive_mb_Listener mbTimeout endpointRef env
(
mbStopTime
,
env
)
=
getMbStopTime
mbTimeout
env
(
errCode
,
env
)
=
selectChC
isIOProg
False
mbStopTime
{
endpointRef
}
{
LISTENER
}
{}
env
|
errCode
<>
0
// the timeout expired (or some fatal error)
=
(
TR_Expired
,
No
thing
,
env
)
=
(
TR_Expired
,
?
No
ne
,
env
)
=
accept
endpointRef
env
accept
endpointRef
env
#
((
errCode
,
host
,
newEpRef
),
env
)
=
acceptC
endpointRef
env
|
errCode
<>
0
=
(
TR_NoSuccess
,
No
thing
,
env
)
=
(
TR_NoSuccess
,
?
No
ne
,
env
)
#
(
duplexChan
,
env
)
=
createDuplexChan
newEpRef
env
=
(
TR_Success
,
Just
(
pack_ipaddr
host
,
duplexChan
),
env
)
=
(
TR_Success
,
?
Just
(
pack_ipaddr
host
,
duplexChan
),
env
)
/////////////////////// TCP channels /////////////////////////////////
...
...
@@ -88,26 +88,26 @@ instance closeRChannel TCP_RChannel_
#
(
endpointRef
,
_)
=
unpack_tcprchan
ch
=
close_tcprchan
endpointRef
env
receive_mb_TCP
::
!(
Maybe
Timeout
)
!(!
EndpointRef
,!
Int
)
!*
env
->
(!
TimeoutReport
,
!
Maybe
ByteSeq
,
!*
env
)
receive_mb_TCP
::
!(
?
Timeout
)
!(!
EndpointRef
,!
Int
)
!*
env
->
(!
TimeoutReport
,
!
?
ByteSeq
,
!*
env
)
|
ChannelEnv
env
receive_mb_TCP
mbTimeout
rchan
=:(
endpointRef
,
maxSize
)
env
|
isJust
mbTimeout
&&
(
fromJust
mbTimeout
)<
0
=
(
TR_Expired
,
No
thing
,
env
)
=
(
TR_Expired
,
?
No
ne
,
env
)
#!
(
receivedData
,
env
)
=
receiveC
endpointRef
maxSize
env
|
size
receivedData
>
0
=
(
TR_Success
,
Just
(
toByteSeq
receivedData
),
env
)
=
(
TR_Success
,
?
Just
(
toByteSeq
receivedData
),
env
)
#!
(
mbStopTime
,
env
)
=
getMbStopTime
mbTimeout
env
(
isIOProg
,
env
)
=
channelEnvKind
env
(
errCode
,
env
)
=
selectChC
isIOProg
False
mbStopTime
{
endpointRef
}
{
RCHANNEL
}
{}
env
|
errCode
==
1
// timeout expired
=
(
TR_Expired
,
No
thing
,
env
)
=
(
TR_Expired
,
?
No
ne
,
env
)
|
errCode
==
3
// some error
=
(
TR_NoSuccess
,
No
thing
,
env
)
=
(
TR_NoSuccess
,
?
No
ne
,
env
)
#!
(
receivedData
,
env
)
=
receiveC
endpointRef
maxSize
env
|
size
receivedData
>
0
=
(
TR_Success
,
Just
(
toByteSeq
receivedData
),
env
)
=
(
TR_NoSuccess
,
No
thing
,
env
)
=
(
TR_Success
,
?
Just
(
toByteSeq
receivedData
),
env
)
=
(
TR_NoSuccess
,
?
No
ne
,
env
)
instance
Send
TCP_SChannel_
where
...
...
@@ -204,16 +204,16 @@ flushBuffers_Loop nonBlocking mbStopTime isIOProg endpointRef
=
flushBuffers_Loop
nonBlocking
mbStopTime
isIOProg
endpointRef
{
buffer
&
bBegin
=
bBegin
+
bytesSent
}
(
bytesSent
+
akku
)
env
lookupIPAddress
::
!
String
!*
env
->
(!
Maybe
IPAddress
,
!*
env
)
->
(!
?
IPAddress
,
!*
env
)
|
ChannelEnv
env
lookupIPAddress
inetAddr
env
#
((
errCode
,
inetHost
),
env
)
=
lookupHost_syncC
(
inetAddr
+++
"
\0
"
)
env
|
errCode
<>
0
=
(
No
thing
,
env
)
=
(
Just
(
pack_ipaddr
inetHost
),
env
)
=
(
?
No
ne
,
env
)
=
(
?
Just
(
pack_ipaddr
inetHost
),
env
)
connectTCP_MT
::
!(
Maybe
Timeout
)
!(!
IPAddress
,!
Port
)
!*
env
->
(!
TimeoutReport
,
!
Maybe
TCP_DuplexChannel
,
!*
env
)
connectTCP_MT
::
!(
?
Timeout
)
!(!
IPAddress
,!
Port
)
!*
env
->
(!
TimeoutReport
,
!
?
TCP_DuplexChannel
,
!*
env
)
|
ChannelEnv
env
connectTCP_MT
mbTimeout
(
inetHost
,
inetPort
)
env
#!
destination
=
(
unpack_ipaddr
inetHost
,
inetPort
)
...
...
@@ -222,20 +222,20 @@ connectTCP_MT mbTimeout (inetHost,inetPort) env
((
errCode
,
timeoutExpired
,
endpointRef
),
env
)
=
os_connectTCP_sync
chanEnvKind
mbStopTime
destination
env
|
timeoutExpired
=
(
TR_Expired
,
No
thing
,
env
)
=
(
TR_Expired
,
?
No
ne
,
env
)
|
errCode
<>
0
=
(
TR_NoSuccess
,
No
thing
,
env
)
=
(
TR_NoSuccess
,
?
No
ne
,
env
)
#!
(
duplexChan
,
env
)
=
createDuplexChan
endpointRef
env
=
(
TR_Success
,
Just
duplexChan
,
env
)
=
(
TR_Success
,
?
Just
duplexChan
,
env
)
openTCP_Listener
::
!
Port
!*
env
->
(!
Bool
,
!
Maybe
TCP_Listener
,
!*
env
)
->
(!
Bool
,
!
?
TCP_Listener
,
!*
env
)
|
ChannelEnv
env
openTCP_Listener
port
env
#
((
errCode
,
endpointRef
),
env
)
=
openTCP_ListenerC
port
env
|
errCode
<>
0
=
(
False
,
No
thing
,
env
)
=
(
True
,
Just
(
pack_tcplistener
endpointRef
),
env
)
=
(
False
,
?
No
ne
,
env
)
=
(
True
,
?
Just
(
pack_tcplistener
endpointRef
),
env
)
instance
MaxSize
TCP_RChannel_
where
...
...
@@ -307,7 +307,7 @@ class SelectReceive channels
accRChannels
::
(
PrimitiveRChannel
->
(
x
,
PrimitiveRChannel
))
!*
channels
->
(![
x
],
!*
channels
)
getRState
::
!
Int
!*
channels
!*
env
->
(!
Maybe
SelectResult
,
!*
channels
,
!*
env
)
|
ChannelEnv
env
->
(!
?
SelectResult
,
!*
channels
,
!*
env
)
|
ChannelEnv
env
class
SelectSend
channels
where
...
...
@@ -409,7 +409,7 @@ instance SelectReceive TCP_Listeners
getState
listener
env
#!
endpointRef
=
unpack_tcplistener
listener
(
cReqAvail
,
env
)
=
os_connectrequestavailable
endpointRef
env
=
(
if
cReqAvail
(
Just
SR_Available
)
No
thing
,
=
(
if
cReqAvail
(
?
Just
SR_Available
)
?
No
ne
,
pack_tcplistener
endpointRef
,
env
)
...
...
@@ -434,16 +434,16 @@ instance SelectReceive TCP_Void
accRChannels
_
void
=
([],
void
)
getRState
_
void
env
=
(
No
thing
,
void
,
env
)
=
(
?
No
ne
,
void
,
env
)
getStateRchan
channel
env
#!
(
isAvailable
,
channel
,
env
)
=
available
channel
env
|
isAvailable
=
(
Just
SR_Available
,
channel
,
env
)
=
(
?
Just
SR_Available
,
channel
,
env
)
#!
(
isEom
,
channel
,
env
)
=
eom
channel
env
|
isEom
=
(
Just
SR_EOM
,
channel
,
env
)
=
(
No
thing
,
channel
,
env
)
=
(
?
Just
SR_EOM
,
channel
,
env
)
=
(
?
No
ne
,
channel
,
env
)
instance
getNrOfChannels
(
TCP_Pair
*
x
*
y
)
|
getNrOfChannels
x
&
getNrOfChannels
y
where
...
...
@@ -499,7 +499,7 @@ instance toString SelectResult
toString
SR_Sendable
=
"SR_Sendable"
toString
SR_Disconnected
=
"SR_Disconnected"
selectChannel_MT
::
!(
Maybe
Timeout
)
!*
r_channels
!*
s_channels
!*
env
selectChannel_MT
::
!(
?
Timeout
)
!*
r_channels
!*
s_channels
!*
env
->
(![(
Int
,
SelectResult
)],
!*
r_channels
,
!*
s_channels
,
!*
env
)
|
SelectReceive
r_channels
&
SelectSend
s_channels
&
ChannelEnv
env
selectChannel_MT
mbTimeout
r_channels
s_channels
env
...
...
@@ -548,7 +548,7 @@ pollRState [] akku r_channels env
=
(
reverse
akku
,
r_channels
,
env
)
pollRState
[
rcvIndex
:
rcvIndices
]
akku
r_channels
env
#!
(
mbResult
,
r_channels
,
env
)
=
getRState
rcvIndex
r_channels
env
|
isNo
thing
mbResult
|
isNo
ne
mbResult
=
pollRState
rcvIndices
akku
r_channels
env
#!
result
=
fromJust
mbResult
|
result
<>
SR_Available
&&
result
<>
SR_EOM
...
...
@@ -579,25 +579,25 @@ instance Receive TCP_RCharStream_
where
receive_MT
mbTimeout
rbs
=:{
rbs_buffer
,
rbs_index
}
env
|
isJust
mbTimeout
&&
(
fromJust
mbTimeout
)<
0
=
(
TR_Expired
,
No
thing
,
rbs
,
env
)
=
(
TR_Expired
,
?
No
ne
,
rbs
,
env
)
|
rbs_index
<
(
size
rbs_buffer
)
=
(
TR_Success
,
Cast
(
Just
rbs_buffer
.[
rbs_index
]),
{
rbs
&
rbs_index
=
inc
rbs_index
},
env
)
=
(
TR_Success
,
Cast
(
?
Just
rbs_buffer
.[
rbs_index
]),
{
rbs
&
rbs_index
=
inc
rbs_index
},
env
)
#!
rbs_rchan
=
rbs
.
rbs_rchan
(
toReport
,
mbData
,
rbs_rchan
,
env
)
=
receive_MT
mbTimeout
rbs_rchan
env
|
toReport
==
TR_Success
#!
data
=
toString
(
fromJust
mbData
)
=
(
toReport
,
Cast
(
Just
data
.[
0
]),
=
(
toReport
,
Cast
(
?
Just
data
.[
0
]),
{
rbs
&
rbs_rchan
=
rbs_rchan
,
rbs_index
=
1
,
rbs_buffer
=
data
},
env
)
=
(
toReport
,
No
thing
,
{
rbs
&
rbs_rchan
=
rbs_rchan
,
rbs_buffer
=
""
,
rbs_index
=
0
},
env
)
=
(
toReport
,
?
No
ne
,
{
rbs
&
rbs_rchan
=
rbs_rchan
,
rbs_buffer
=
""
,
rbs_index
=
0
},
env
)
receiveUpTo
maxLength
rbs
=:{
rbs_buffer
,
rbs_index
}
env
|
maxLength
<=
0
=([],
rbs
,
env
)
#!
nrOfCharsInBuffer
=
max
(
size
rbs_buffer
-
rbs_index
)
0
|
nrOfCharsInBuffer
>=
maxLength
// enough data is buffered in rbs_buffer
=
(
Cast
[
rbs_buffer
.[
i
]
\\
i
<-[
rbs_index
..
rbs_index
+
maxLength
-1
]],
{
rbs
&
rbs_index
=
rbs_index
+
maxLength
},
env
)
#!
(_,
mbData
,
rbs_rchan
,
env
)
=
receive_MT
(
Just
0
)
rbs
.
rbs_rchan
env
#!
(_,
mbData
,
rbs_rchan
,
env
)
=
receive_MT
(
?
Just
0
)
rbs
.
rbs_rchan
env
charsInBuffer
=
[
rbs_buffer
.[
i
]
\\
i
<-[
rbs_index
..(
size
rbs_buffer
)
-1
]]
|
isNo
thing
mbData
// available is False->return the rbs_buffer
|
isNo
ne
mbData
// available is False->return the rbs_buffer
=
(
Cast
charsInBuffer
,
{
rbs
&
rbs_rchan
=