{-# 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 has two states:

   - Idle state: we have nothing to send and don't want to be notified when
                 the socket becomes writable.

   - Blocked state: we have something to send and want to be notified when
                   the socket becomes writable.

   idleK handles the idle state. Transistion to the idleState is done
   with goIdleK. idleK should only be called when in the idle state.

   blockedK handles the blocked state. Transition to the blocked state is done
   with goBlockedK. blockedK should only be called when in the blocked state.

   writeK is called in blocked mode when the socket become writable. If there
   is something left in the buffer to write, writeK writes a chunk to the
   socket and continues in blocked mode, otherwise writeK switches to
   idle mode.
-}

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 =
    -- Start in idle mode
    K [Char] () -> F [Char] ()
forall a b. K a b -> F a b
ioF K [Char] ()
idleK
  where
    -- To be called while in idle mode only:
    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)

    -- To swich from blocked to idle mode:
    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

    -- To switch from idle mode to blocked mode:
    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

    -- To be called while in blocked mode only:
    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

    -- To be called while in blocked mode, when socket becomes writable:
    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 -- Ignore errors?!

    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
$
      --sIOsucc (CloseSocket socket) $
      -- Can't close the socket until the receiver (if any) has deselected it!
      () -> 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

--buf0 = Buf "" empty
buf1 :: [Char] -> Buffer
buf1 [Char]
str = [Char] -> QUEUE [Char] -> Buffer
Buf [Char]
str QUEUE [Char]
forall a. QUEUE a
empty -- pre: str/=""

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) -- str=="" to indicate eos

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