{-# LANGUAGE CPP #-}
module AsyncTransmitter(asyncTransmitterF,asyncTransmitterF',closerF) where
import Sockets
import Srequest
import FRequest
import Message(message)
import NullF(getK,nullK,nullF)
import Fudget()
import FudgetIO
import CompOps((>==<))
import IoF(ioF)
import DialogueIO hiding (IOError)
import qualified PackedString as PS
import Queue(QUEUE,empty,enter,qremove)
asyncTransmitterF :: Socket -> F [Char] b
asyncTransmitterF Socket
socket = Socket -> F () b
forall ans ho. Socket -> F ans ho
closerF Socket
socket F () b -> F [Char] () -> F [Char] b
forall a1 b a2. F a1 b -> F a2 a1 -> F a2 b
>==< Socket -> F [Char] ()
asyncTransmitterF' Socket
socket
asyncTransmitterF' :: Socket -> F [Char] ()
asyncTransmitterF' Socket
socket =
K [Char] () -> F [Char] ()
forall a b. K a b -> F a b
ioF K [Char] ()
idleK
where
idleK :: K [Char] ()
idleK = (FResponse -> K [Char] ())
-> ([Char] -> K [Char] ()) -> K [Char] ()
forall t2 ho. (FResponse -> K t2 ho) -> (t2 -> K t2 ho) -> K t2 ho
getMsg (K [Char] () -> FResponse -> K [Char] ()
forall a b. a -> b -> a
const K [Char] ()
idleK) [Char] -> K [Char] ()
high
where
high :: [Char] -> K [Char] ()
high [Char]
"" = K [Char] ()
forall hi. K hi ()
closeK
high [Char]
str = Buffer -> K [Char] ()
goBlockedK ([Char] -> Buffer
buf1 [Char]
str)
goIdleK :: K [Char] ()
goIdleK = [Descriptor] -> K [Char] () -> K [Char] ()
forall (f :: * -> * -> *) hi ho.
FudgetIO f =>
[Descriptor] -> f hi ho -> f hi ho
select [] (K [Char] () -> K [Char] ()) -> K [Char] () -> K [Char] ()
forall a b. (a -> b) -> a -> b
$ K [Char] ()
idleK
goBlockedK :: Buffer -> K [Char] ()
goBlockedK Buffer
buf =
[Descriptor] -> K [Char] () -> K [Char] ()
forall (f :: * -> * -> *) hi ho.
FudgetIO f =>
[Descriptor] -> f hi ho -> f hi ho
select [Socket -> Descriptor
OutputSocketDe Socket
socket] (K [Char] () -> K [Char] ()) -> K [Char] () -> K [Char] ()
forall a b. (a -> b) -> a -> b
$
Buffer -> Int -> K [Char] ()
blockedK Buffer
buf Int
initblocksize
blockedK :: Buffer -> Int -> K [Char] ()
blockedK Buffer
buf Int
n = (FResponse -> K [Char] ())
-> ([Char] -> K [Char] ()) -> K [Char] ()
forall t2 ho. (FResponse -> K t2 ho) -> (t2 -> K t2 ho) -> K t2 ho
getMsg FResponse -> K [Char] ()
low [Char] -> K [Char] ()
high
where
low :: FResponse -> K [Char] ()
low (DResp (AsyncInput (Descriptor
_,AEvent
SocketWritable))) = Buffer -> Int -> K [Char] ()
writeK Buffer
buf Int
n
high :: [Char] -> K [Char] ()
high [Char]
str = Buffer -> Int -> K [Char] ()
blockedK (Buffer -> [Char] -> Buffer
putbuf Buffer
buf [Char]
str) Int
n
writeK :: Buffer -> Int -> K [Char] ()
writeK Buffer
buf Int
n =
case Buffer -> Int -> GetBuf
getbuf Buffer
buf Int
n of
GetBuf
Empty -> K [Char] ()
goIdleK
GetBuf
EoS -> K [Char] ()
forall hi. K hi ()
closeK
More PackedString
ps Buffer
buf' -> SocketRequest
-> (IOError -> K [Char] ())
-> (SocketResponse -> K [Char] ())
-> K [Char] ()
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
SocketRequest
-> (IOError -> f b ho) -> (SocketResponse -> f b ho) -> f b ho
sIOerr (Socket -> PackedString -> SocketRequest
WriteSocketPS Socket
socket PackedString
ps) IOError -> K [Char] ()
forall p. p -> K [Char] ()
errK SocketResponse -> K [Char] ()
okK
where
okK :: SocketResponse -> K [Char] ()
okK (Wrote Int
n') = Buffer -> Int -> K [Char] ()
blockedK Buffer
buf' Int
n
errK :: p -> K [Char] ()
errK p
_ = Buffer -> Int -> K [Char] ()
blockedK Buffer
buf' Int
n
closeK :: K hi ()
closeK =
[Descriptor] -> K hi () -> K hi ()
forall (f :: * -> * -> *) hi ho.
FudgetIO f =>
[Descriptor] -> f hi ho -> f hi ho
select [] (K hi () -> K hi ()) -> K hi () -> K hi ()
forall a b. (a -> b) -> a -> b
$
() -> K hi () -> K hi ()
forall (f :: * -> * -> *) ho hi.
FudgetIO f =>
ho -> f hi ho -> f hi ho
putHigh () (K hi () -> K hi ()) -> K hi () -> K hi ()
forall a b. (a -> b) -> a -> b
$
K hi ()
forall hi ho. K hi ho
nullK
closerF :: Socket -> F ans ho
closerF Socket
socket =
(ans -> F ans ho) -> F ans ho
forall (f :: * -> * -> *) ans ho.
FudgetIO f =>
(ans -> f ans ho) -> f ans ho
getHigh ((ans -> F ans ho) -> F ans ho) -> (ans -> F ans ho) -> F ans ho
forall a b. (a -> b) -> a -> b
$ \ ans
_ ->
SocketRequest -> F ans ho -> F ans ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
SocketRequest -> f b ho -> f b ho
sIOsucc (Socket -> SocketRequest
CloseSocket Socket
socket) (F ans ho -> F ans ho) -> F ans ho -> F ans ho
forall a b. (a -> b) -> a -> b
$
F ans ho
forall hi ho. F hi ho
nullF
getMsg :: (FResponse -> K t2 ho) -> (t2 -> K t2 ho) -> K t2 ho
getMsg FResponse -> K t2 ho
l t2 -> K t2 ho
h = Cont (K t2 ho) (KEvent t2)
forall hi ho. Cont (K hi ho) (KEvent hi)
getK Cont (K t2 ho) (KEvent t2) -> Cont (K t2 ho) (KEvent t2)
forall a b. (a -> b) -> a -> b
$ (FResponse -> K t2 ho) -> (t2 -> K t2 ho) -> KEvent t2 -> K t2 ho
forall t1 p t2. (t1 -> p) -> (t2 -> p) -> Message t1 t2 -> p
message FResponse -> K t2 ho
l t2 -> K t2 ho
h
data Buffer = Buf String (QUEUE String)
data GetBuf = More PS.PackedString Buffer | Empty | EoS
buf1 :: [Char] -> Buffer
buf1 [Char]
str = [Char] -> QUEUE [Char] -> Buffer
Buf [Char]
str QUEUE [Char]
forall a. QUEUE a
empty
putbuf :: Buffer -> [Char] -> Buffer
putbuf (Buf [Char]
s QUEUE [Char]
q) [Char]
str = [Char] -> QUEUE [Char] -> Buffer
Buf [Char]
s (QUEUE [Char] -> [Char] -> QUEUE [Char]
forall a. QUEUE a -> a -> QUEUE a
enter QUEUE [Char]
q [Char]
str)
getbuf :: Buffer -> Int -> GetBuf
getbuf (Buf [Char]
s QUEUE [Char]
q) Int
n = [Char] -> QUEUE [Char] -> GetBuf
getbuf' [Char]
s QUEUE [Char]
q
where
getbuf' :: [Char] -> QUEUE [Char] -> GetBuf
getbuf' [Char]
"" QUEUE [Char]
q =
case QUEUE [Char] -> Maybe ([Char], QUEUE [Char])
forall a. QUEUE a -> Maybe (a, QUEUE a)
qremove QUEUE [Char]
q of
Maybe ([Char], QUEUE [Char])
Nothing -> GetBuf
Empty
Just ([Char]
s,QUEUE [Char]
q') ->
if [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
s
then GetBuf
EoS
else [Char] -> QUEUE [Char] -> GetBuf
getbuf'' [Char]
s QUEUE [Char]
q'
getbuf' [Char]
s QUEUE [Char]
q = [Char] -> QUEUE [Char] -> GetBuf
getbuf'' [Char]
s QUEUE [Char]
q
getbuf'' :: [Char] -> QUEUE [Char] -> GetBuf
getbuf'' [Char]
s QUEUE [Char]
q =
case Int -> [Char] -> ([Char], [Char])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [Char]
s of
([Char]
s1,[Char]
s2) -> PackedString -> Buffer -> GetBuf
More ([Char] -> PackedString
PS.packString [Char]
s1) ([Char] -> QUEUE [Char] -> Buffer
Buf [Char]
s2 QUEUE [Char]
q)
initblocksize :: Int
initblocksize = Int
512 :: Int
#if defined(__GLASGOW_HASKELL__) || defined(__PFE__)
nullPS :: PackedString -> Bool
nullPS = PackedString -> Bool
PS.nullPS
#else
nullPS = PS.null
#endif