{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
{- Obsolete OPTIONS -optc-I/usr/X11R6/include -optc-DNON_POSIX_SOURCE -fvia-C -}
--
module AsyncInput
   (doSocketRequest,doSelect,getAsyncInput',initXCall,XCallState)
  where
import P_IO_data({-Request(..),-}Response(..))
import Xtypes
import Sockets as S
import DLValue
import Unsafe.Coerce -- !!!
--import ResourceIds
import Utils(swap)

import XCallTypes
import StructFuns
import Xlib
import EncodeEvent
import Marshall
import MyForeign
import GHC.Exts(addrToAny# )
import GHC.Ptr(FunPtr(..))

--import Ap
import HbcUtils(lookupWithDefault)
import Data.Maybe(mapMaybe)
import Control.Monad(when)
import Data.Traversable(traverse)

import PQueue

import Data.IORef(newIORef,readIORef,writeIORef,IORef)
import System.Posix.DynamicLinker as DL

import PackedString(unpackPS,lengthPS{-,packCBytesST,psToByteArray-})

default (Int)

#include "newstructfuns.h"

H_STRUCTTYPE(fd_set)

allocaInt :: (Addr -> IO c) -> IO c
allocaInt = Int -> (Addr -> IO c) -> IO c
forall a c. Storable a => a -> (Addr -> IO c) -> IO c
allocaElem (Int
0::Int)

type AiTable = [(Fd,Descriptor)]

type IOVar a = IORef a

newIOVar :: a -> IO (IORef a)
newIOVar = a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef
readIOVar :: IORef a -> IO a
readIOVar = IORef a -> IO a
forall a. IORef a -> IO a
readIORef
writeIOVar :: IORef a -> a -> IO ()
writeIOVar = IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef

type MsTime = Int

data XCallState = XCallState
      Cfd_set -- ^ read fd_set
      (IOVar Fd) -- ^ highest fd in read fd_set
      (IOVar AiTable)
      (IOVar (PQueue MsTime (MsTime,Timer)))
      (IOVar Time)

initXCall :: IO XCallState
initXCall =
 Cfd_set
-> IOVar Fd
-> IOVar AiTable
-> IOVar (PQueue Int (Int, Timer))
-> IOVar Int
-> XCallState
XCallState
  (Cfd_set
 -> IOVar Fd
 -> IOVar AiTable
 -> IOVar (PQueue Int (Int, Timer))
 -> IOVar Int
 -> XCallState)
-> IO Cfd_set
-> IO
     (IOVar Fd
      -> IOVar AiTable
      -> IOVar (PQueue Int (Int, Timer))
      -> IOVar Int
      -> XCallState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Cfd_set
forall a. IsPtr a => IO a
newPtr
  IO
  (IOVar Fd
   -> IOVar AiTable
   -> IOVar (PQueue Int (Int, Timer))
   -> IOVar Int
   -> XCallState)
-> IO (IOVar Fd)
-> IO
     (IOVar AiTable
      -> IOVar (PQueue Int (Int, Timer)) -> IOVar Int -> XCallState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Fd -> IO (IOVar Fd)
forall a. a -> IO (IORef a)
newIOVar Fd
0
  IO
  (IOVar AiTable
   -> IOVar (PQueue Int (Int, Timer)) -> IOVar Int -> XCallState)
-> IO (IOVar AiTable)
-> IO (IOVar (PQueue Int (Int, Timer)) -> IOVar Int -> XCallState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AiTable -> IO (IOVar AiTable)
forall a. a -> IO (IORef a)
newIOVar []
  IO (IOVar (PQueue Int (Int, Timer)) -> IOVar Int -> XCallState)
-> IO (IOVar (PQueue Int (Int, Timer)))
-> IO (IOVar Int -> XCallState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PQueue Int (Int, Timer) -> IO (IOVar (PQueue Int (Int, Timer)))
forall a. a -> IO (IORef a)
newIOVar PQueue Int (Int, Timer)
forall a b. PQueue a b
empty
  IO (IOVar Int -> XCallState) -> IO (IOVar Int) -> IO XCallState
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO (IOVar Int)
forall a. a -> IO (IORef a)
newIOVar Int
0

type Fd = Int32

foreign import ccall "unistd.h read" cread :: Fd -> Addr -> CSize -> IO CSize
foreign import ccall "unistd.h write" cwrite :: Fd -> CString -> CSize -> IO CSize
foreign import ccall "sys/socket.h" accept :: Fd -> CsockAddr -> Addr -> IO Fd

getAsyncInput' :: XCallState -> IO Response
getAsyncInput' (XCallState Cfd_set
fds IOVar Fd
maxfdvar IOVar AiTable
aitable IOVar (PQueue Int (Int, Timer))
tq IOVar Int
tno) =
 AsyncInput -> Response
AsyncInput (AsyncInput -> Response) -> IO AsyncInput -> IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
   AiTable
ai <- IOVar AiTable -> IO AiTable
forall a. IORef a -> IO a
readIOVar IOVar AiTable
aitable
   let timeLeft :: IO (Maybe Int)
timeLeft =
	  do PQueue Int (Int, Timer)
tqv <- IOVar (PQueue Int (Int, Timer)) -> IO (PQueue Int (Int, Timer))
forall a. IORef a -> IO a
readIOVar IOVar (PQueue Int (Int, Timer))
tq
	     case PQueue Int (Int, Timer)
-> Maybe ((Int, (Int, Timer)), PQueue Int (Int, Timer))
forall a b. PQueue a b -> Maybe ((a, b), PQueue a b)
inspect PQueue Int (Int, Timer)
tqv of
	       Maybe ((Int, (Int, Timer)), PQueue Int (Int, Timer))
Nothing -> Maybe Int -> IO (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
	       Just ((Int
t,(Int, Timer)
_),PQueue Int (Int, Timer)
_) ->
		 do Int
ms <- IO Int
mstime
		    Maybe Int -> IO (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> IO (Maybe Int))
-> (Int -> Maybe Int) -> Int -> IO (Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (Int -> Int) -> Int -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> IO (Maybe Int)) -> Int -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ms
   
   let doSelect :: IO AsyncInput
doSelect = do
	  Maybe CtimeVal
timeout <- (Int -> IO CtimeVal) -> Maybe Int -> IO (Maybe CtimeVal)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Int -> IO CtimeVal
newTimeVal (Maybe Int -> IO (Maybe CtimeVal))
-> IO (Maybe Int) -> IO (Maybe CtimeVal)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Maybe Int)
timeLeft
          Cfd_set
readfds <- IO Cfd_set
forall a. IsPtr a => IO a
newPtr
--	  _casm_ ``bcopy(%0,%1,sizeof(fd_set));'' fds readfds
	  Cfd_set -> Cfd_set -> IO ()
bcopy_fdset Cfd_set
fds Cfd_set
readfds
          Fd
maxfdvar <- IOVar Fd -> IO Fd
forall a. IORef a -> IO a
readIOVar IOVar Fd
maxfdvar
	  Fd
n <- Fd -> Cfd_set -> Maybe CtimeVal -> IO Fd
select (Fd
maxfdvarFd -> Fd -> Fd
forall a. Num a => a -> a -> a
+Fd
1) Cfd_set
readfds Maybe CtimeVal
timeout
	  IO () -> (CtimeVal -> IO ()) -> Maybe CtimeVal -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) CtimeVal -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr Maybe CtimeVal
timeout
	  let findFd :: Fd -> IO AsyncInput
findFd Fd
fd = do
		  Bool
s <- Int -> Bool
forall a. FromC a => Int -> a
fromC (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
--		       _casm_ ``%r=FD_ISSET(%0,(fd_set*)%1);'' fd readfds
		       Fd -> Cfd_set -> IO Int
fd_isset Fd
fd Cfd_set
readfds
		  if Bool -> Bool
not Bool
s then Fd -> IO AsyncInput
findFd (Fd
fdFd -> Fd -> Fd
forall a. Num a => a -> a -> a
+Fd
1) 
		    else let d :: Descriptor
d = Fd -> Descriptor
lookAi Fd
fd in case Descriptor
d of
		       DisplayDe Display
_ -> Fd -> Descriptor -> IO AsyncInput
forall p. p -> Descriptor -> IO AsyncInput
mkEvent Fd
fd Descriptor
d
		       SocketDe Socket
_ ->
		         let bufsize :: Int
bufsize = Int
2000
			 in Int -> (Addr -> IO AsyncInput) -> IO AsyncInput
forall c. Int -> (Addr -> IO c) -> IO c
alloca Int
bufsize ((Addr -> IO AsyncInput) -> IO AsyncInput)
-> (Addr -> IO AsyncInput) -> IO AsyncInput
forall a b. (a -> b) -> a -> b
$ \ Addr
buf ->
			 do CSize
got <- String -> (CSize -> Bool) -> IO CSize -> IO CSize
forall b. String -> (b -> Bool) -> IO b -> IO b
tryP String
"read" (CSize -> CSize -> Bool
forall a. Ord a => a -> a -> Bool
>=CSize
0) (IO CSize -> IO CSize) -> IO CSize -> IO CSize
forall a b. (a -> b) -> a -> b
$ Fd -> Addr -> CSize -> IO CSize
cread Fd
fd Addr
buf (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bufsize)
			    String
str <- CString -> Int -> IO String
unmarshallString' (Addr -> CString
CString Addr
buf) (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
got)
			    AsyncInput -> IO AsyncInput
forall (m :: * -> *) a. Monad m => a -> m a
return (Descriptor
d,String -> AEvent
SocketRead String
str)
		       LSocketDe LSocket
_ ->
		         (Addr -> IO AsyncInput) -> IO AsyncInput
forall c. (Addr -> IO c) -> IO c
allocaInt ((Addr -> IO AsyncInput) -> IO AsyncInput)
-> (Addr -> IO AsyncInput) -> IO AsyncInput
forall a b. (a -> b) -> a -> b
$ \ Addr
addrlen ->
			 do CsockAddr
addr <- IO CsockAddr
newsockAddr
			    Fd
sfd <- String -> (Fd -> Bool) -> IO Fd -> IO Fd
forall b. String -> (b -> Bool) -> IO b -> IO b
tryP String
"accept" (Fd -> Fd -> Bool
forall a. Ord a => a -> a -> Bool
>=Fd
0) (IO Fd -> IO Fd) -> IO Fd -> IO Fd
forall a b. (a -> b) -> a -> b
$ 
				--_ccall_ ACCEPT fd addr addrlen
				Fd -> CsockAddr -> Addr -> IO Fd
accept Fd
fd CsockAddr
addr Addr
addrlen
			    Int
sf <- Fd -> String -> IO Int
getfilep Fd
sfd String
"r+"
			    --buf <- stToIO $ newCharArray (1,1000)
			    --tryP "hostName" (==0) $ _ccall_ hostName addr buf
			    --peer <- cstring <$> mutByteArr2Addr buf
			    let peer :: String
peer = String
""
			    AsyncInput -> IO AsyncInput
forall (m :: * -> *) a. Monad m => a -> m a
return (Descriptor
d,Socket -> String -> AEvent
SocketAccepted (Int -> Socket
So Int
sf) String
peer)

		       Descriptor
_ -> String -> IO AsyncInput
forall a. HasCallStack => String -> a
error String
"getAsyncInput3"
          AsyncInput
e <- if Fd
n Fd -> Fd -> Bool
forall a. Eq a => a -> a -> Bool
== -Fd
1 then String -> IO AsyncInput
forall a. HasCallStack => String -> a
error (String -> IO AsyncInput) -> ShowS -> String -> IO AsyncInput
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"select "String -> ShowS
forall a. [a] -> [a] -> [a]
++) (String -> IO AsyncInput) -> IO String -> IO AsyncInput
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> IO String
strerror (Int -> IO String) -> IO Int -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Int
errno
	       else if Fd
n Fd -> Fd -> Bool
forall a. Ord a => a -> a -> Bool
> Fd
0 then Fd -> IO AsyncInput
findFd Fd
0
	            else do Timer
tno <- IOVar (PQueue Int (Int, Timer)) -> IO Timer
forall a b. (Ord a, Num a) => IORef (PQueue a (a, b)) -> IO b
removetimeq IOVar (PQueue Int (Int, Timer))
tq
	                    AsyncInput -> IO AsyncInput
forall (m :: * -> *) a. Monad m => a -> m a
return (Timer -> Descriptor
TimerDe Timer
tno,AEvent
TimerAlarm)
	  Cfd_set -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr Cfd_set
readfds
	  AsyncInput -> IO AsyncInput
forall (m :: * -> *) a. Monad m => a -> m a
return AsyncInput
e

       mkEvent :: p -> Descriptor -> IO AsyncInput
mkEvent p
fd Descriptor
d = do
           (WindowId
window,XEvent
fev) <- {-motionCompress display =<<-} Display -> IO (WindowId, XEvent)
getNextEvent Display
display
	   AsyncInput -> IO AsyncInput
forall (m :: * -> *) a. Monad m => a -> m a
return (Descriptor
descriptor,(WindowId, XEvent) -> AEvent
XEvent (WindowId
window,XEvent
fev))
         where descriptor :: Descriptor
descriptor@(DisplayDe Display
display) = Descriptor
d
         
       lookAi :: Fd -> Descriptor
lookAi = AiTable -> Descriptor -> Fd -> Descriptor
forall a b. Eq a => [(a, b)] -> b -> a -> b
lookupWithDefault AiTable
ai (String -> Descriptor
forall a. HasCallStack => String -> a
error String
"getAsyncInput2")
       dispde :: (a, Descriptor) -> Maybe (a, Descriptor)
dispde x :: (a, Descriptor)
x@(a
fd,DisplayDe Display
_) = (a, Descriptor) -> Maybe (a, Descriptor)
forall a. a -> Maybe a
Just (a, Descriptor)
x
       dispde (a, Descriptor)
_ = Maybe (a, Descriptor)
forall a. Maybe a
Nothing
   case ((Fd, Descriptor) -> Maybe (Fd, Descriptor)) -> AiTable -> AiTable
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Fd, Descriptor) -> Maybe (Fd, Descriptor)
forall a. (a, Descriptor) -> Maybe (a, Descriptor)
dispde AiTable
ai of
       [] -> IO AsyncInput
doSelect
       (Fd
fd,d :: Descriptor
d@(DisplayDe Display
display)):AiTable
_ -> do
         Int
q <- Display -> IO Int
xPending Display
display
         if Int
qInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0 then Fd -> Descriptor -> IO AsyncInput
forall p. p -> Descriptor -> IO AsyncInput
mkEvent Fd
fd Descriptor
d else IO AsyncInput
doSelect

newTimeVal :: Int -> IO CtimeVal
newTimeVal Int
tleft =
  do CtimeVal
timeout <- IO CtimeVal
forall a. IsPtr a => IO a
newPtr
     SET(timeVal,Int,timeout,tv_usec,(tleft `mod` 1000) * 1000)
     SET(timeVal,Int,timeout,tv_sec,(tleft `div` 1000))
     CtimeVal -> IO CtimeVal
forall (m :: * -> *) a. Monad m => a -> m a
return CtimeVal
timeout

foreign import ccall "sys/select.h select" cselect :: Int32 -> Cfd_set -> Cfd_set -> Cfd_set -> CtimeVal -> IO Int32
--foreign import ccall "unistd.h" getdtablesize :: IO Int

select :: Int32 -> Cfd_set -> Maybe CtimeVal -> IO Int32
select :: Fd -> Cfd_set -> Maybe CtimeVal -> IO Fd
select Fd
nfds Cfd_set
readfds Maybe CtimeVal
timeout = IO Fd
start where
 start :: IO Fd
start = do
    Fd
n <- Fd -> Cfd_set -> Cfd_set -> Cfd_set -> CtimeVal -> IO Fd
cselect Fd
nfds Cfd_set
readfds Cfd_set
forall a. IsPtr a => a
nullPtr Cfd_set
forall a. IsPtr a => a
nullPtr (CtimeVal -> (CtimeVal -> CtimeVal) -> Maybe CtimeVal -> CtimeVal
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CtimeVal
forall a. IsPtr a => a
nullPtr CtimeVal -> CtimeVal
forall a. a -> a
id Maybe CtimeVal
timeout)
{-
      case timeout of
        Nothing -> 
           _casm_ ``%r=select(getdtablesize(),%0,NULL,NULL,NULL);'' readfds
	Just t -> 
           _casm_ ``%r=select(getdtablesize(),%0,NULL,NULL,%1);'' readfds t
-}
    
    if Fd
n Fd -> Fd -> Bool
forall a. Eq a => a -> a -> Bool
/= -Fd
1 then Fd -> IO Fd
forall (m :: * -> *) a. Monad m => a -> m a
return Fd
n else do
       Int
e <- IO Int
errno
       if Int
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== CCONST(EINTR) --- || e == CCONST(EAGAIN)
         then IO Fd
start -- again
         else Fd -> IO Fd
forall (m :: * -> *) a. Monad m => a -> m a
return Fd
n
--}
foreign import ccall "asyncinput.h get_errno" errno :: IO Int
--errno :: IO Int
--errno = _casm_ ``%r=errno;''

foreign import ccall "sys/socket.h" listen :: Fd -> Int32 -> IO Int
foreign import ccall "sys/socket.h" socket :: Int32 -> Int32 -> Int32 -> IO Fd
foreign import ccall "stdio.h" fopen :: CString -> CString -> IO Int -- hmm
foreign import ccall "stdio.h" fclose :: Int -> IO Int

foreign import ccall "asyncinput.h" in_connect :: CString -> Int32 -> Int32 -> IO Int32
foreign import ccall "asyncinput.h" in_bind :: Int32 -> Int32 -> IO Fd
foreign import ccall "asyncinput.h" get_stdin :: IO Int

doSocketRequest :: XCallState -> SocketRequest -> IO Response
doSocketRequest (XCallState Cfd_set
fds IOVar Fd
maxfdvar IOVar AiTable
aitable IOVar (PQueue Int (Int, Timer))
tq IOVar Int
tno) SocketRequest
sr =
 case SocketRequest
sr of
   CreateTimer Int
interval Int
first -> do
          PQueue Int (Int, Timer)
tqv <- IOVar (PQueue Int (Int, Timer)) -> IO (PQueue Int (Int, Timer))
forall a. IORef a -> IO a
readIOVar IOVar (PQueue Int (Int, Timer))
tq
          Int
tnov <- IOVar Int -> IO Int
forall a. IORef a -> IO a
readIOVar IOVar Int
tno
	  Int
now <- IO Int
mstime
	  IOVar (PQueue Int (Int, Timer)) -> PQueue Int (Int, Timer) -> IO ()
forall a. IORef a -> a -> IO ()
writeIOVar IOVar (PQueue Int (Int, Timer))
tq (PQueue Int (Int, Timer)
-> (Int, (Int, Timer)) -> PQueue Int (Int, Timer)
forall a b. Ord a => PQueue a b -> (a, b) -> PQueue a b
insert PQueue Int (Int, Timer)
tqv (Int
nowInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
first,(Int
interval,Int -> Timer
Ti Int
tnov)))
	  IOVar Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIOVar IOVar Int
tno (Int
tnovInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
	  SocketResponse -> IO Response
returnS (Timer -> SocketResponse
Timer (Int -> Timer
Ti Int
tnov))
   DestroyTimer Timer
t -> do
          PQueue Int (Int, Timer)
tqv <- IOVar (PQueue Int (Int, Timer)) -> IO (PQueue Int (Int, Timer))
forall a. IORef a -> IO a
readIOVar IOVar (PQueue Int (Int, Timer))
tq
	  IOVar (PQueue Int (Int, Timer)) -> PQueue Int (Int, Timer) -> IO ()
forall a. IORef a -> a -> IO ()
writeIOVar IOVar (PQueue Int (Int, Timer))
tq (PQueue Int (Int, Timer) -> Timer -> PQueue Int (Int, Timer)
forall a1 a2 a3.
Eq a1 =>
PQueue a2 (a3, a1) -> a1 -> PQueue a2 (a3, a1)
remove PQueue Int (Int, Timer)
tqv Timer
t)
	  Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
Success
   OpenSocket String
host Int
port -> do
     CString
chost <- String -> IO CString
marshallString String
host
     Fd
s <- String -> (Fd -> Bool) -> IO Fd -> IO Fd
forall b. String -> (b -> Bool) -> IO b -> IO b
tryP String
"in_connect" (Fd -> Fd -> Bool
forall a. Ord a => a -> a -> Bool
>=Fd
0) (IO Fd -> IO Fd) -> IO Fd -> IO Fd
forall a b. (a -> b) -> a -> b
$ 
--           _casm_ ``%r=in_connect(%0,%1,SOCK_STREAM);'' chost port
           CString -> Fd -> Fd -> IO Fd
in_connect CString
chost (Int -> Fd
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port) (Int -> Fd
forall a b. (Integral a, Num b) => a -> b
fromIntegral CCONST(SOCK_STREAM))
     Int
sf <- Fd -> String -> IO Int
getfilep Fd
s String
"r+"
     CString -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CString
chost
     SocketResponse -> IO Response
returnS (Socket -> SocketResponse
Socket (Int -> Socket
So Int
sf))
   OpenLSocket Int
port -> do
      Fd
s <- String -> (Fd -> Bool) -> IO Fd -> IO Fd
forall b. String -> (b -> Bool) -> IO b -> IO b
tryP String
"in_bind" (Fd -> Fd -> Bool
forall a. Ord a => a -> a -> Bool
>=Fd
0) (IO Fd -> IO Fd) -> IO Fd -> IO Fd
forall a b. (a -> b) -> a -> b
$ if Int
port Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 
--         then _casm_ ``%r=socket(AF_INET,SOCK_STREAM,0);''
           then Fd -> Fd -> Fd -> IO Fd
socket (Int -> Fd
forall a b. (Integral a, Num b) => a -> b
fromIntegral CCONST(AF_INET)) (fromIntegral CCONST(SOCK_STREAM)) 0
--	   else _casm_ ``%r=in_bind(%0,SOCK_STREAM);'' port
	   else Fd -> Fd -> IO Fd
in_bind (Int -> Fd
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port) (Int -> Fd
forall a b. (Integral a, Num b) => a -> b
fromIntegral CCONST(SOCK_STREAM))
      String -> (Int -> Bool) -> IO Int -> IO Int
forall b. String -> (b -> Bool) -> IO b -> IO b
tryP String
"listen" (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0) (IO Int -> IO Int) -> IO Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Fd -> Fd -> IO Int
listen Fd
s Fd
5
      SocketResponse -> Response
SocketResponse (SocketResponse -> Response)
-> (Int -> SocketResponse) -> Int -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LSocket -> SocketResponse
LSocket (LSocket -> SocketResponse)
-> (Int -> LSocket) -> Int -> SocketResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> LSocket
LSo (Int -> Response) -> IO Int -> IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fd -> String -> IO Int
getfilep Fd
s String
"r+"
   WriteSocket Socket
s String
str -> Socket -> String -> IO Response
writeSocket Socket
s String
str
   WriteSocketPS Socket
s PackedString
str ->
      do Socket -> String -> IO Response
writeSocket Socket
s (PackedString -> String
unpackPS PackedString
str) -- grr!
         SocketResponse -> IO Response
returnS (Int -> SocketResponse
Wrote (PackedString -> Int
lengthPS PackedString
str)) -- grr!
{-
     do
      fd <- fileno s
      r <- tryP "WriteSocket[out]" (>=0) $ 
        _casm_ ``%r=write(fileno((FILE*)%0),%1,%2);'' s (psToByteArray str) (lengthPS str)
--        bawrite fd (psToByteArray str) (lengthPS str)
      return (SocketResponse (Wrote r))
-}
   CloseSocket (So Int
s) -> Int -> IO Response
close Int
s
   CloseLSocket (LSo Int
s) -> Int -> IO Response
close Int
s
   SocketRequest
GetStdinSocket -> SocketResponse -> Response
SocketResponse (SocketResponse -> Response)
-> (Int -> SocketResponse) -> Int -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> SocketResponse
Socket (Socket -> SocketResponse)
-> (Int -> Socket) -> Int -> SocketResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Socket
So (Int -> Response) -> IO Int -> IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
--        _casm_ ``%r=stdin;''
	IO Int
get_stdin
   GetSocketName (So Int
s) -> Int -> IO Response
socketname Int
s
   GetLSocketName (LSo Int
s) -> Int -> IO Response
socketname Int
s
   StartProcess String
cmd Bool
doIn Bool
doOut Bool
doErr -> String -> Bool -> Bool -> Bool -> IO Response
startProcess String
cmd Bool
doIn Bool
doOut Bool
doErr
   DLOpen String
path -> do DL
dh <- String -> [RTLDFlags] -> IO DL
dlopen String
path [RTLDFlags
RTLD_LAZY]
                     case DL
dh of
                       DL
Null -> String -> IO Response
forall a. String -> IO a
failu (String -> IO Response) -> IO String -> IO Response
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String
dlerror
                       DL
_ -> SocketResponse -> IO Response
returnS (SocketResponse -> IO Response) -> SocketResponse -> IO Response
forall a b. (a -> b) -> a -> b
$ DLHandle -> SocketResponse
S.DLHandle (DL -> DLHandle
DL DL
dh)
   DLClose (DL DL
dh) -> do DL -> IO ()
dlclose DL
dh ; Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
Success
   DLSym (DL DL
dh) String
name ->
       do FunPtr Addr#
fp <- DL -> String -> IO (FunPtr Any)
forall a. DL -> String -> IO (FunPtr a)
dlsym DL
dh String
name
          case Addr# -> (# Any #)
forall a. Addr# -> (# a #)
addrToAny# Addr#
fp of
            (# Any
hval #) -> SocketResponse -> IO Response
returnS (SocketResponse -> IO Response)
-> (DLValue -> SocketResponse) -> DLValue -> IO Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DLValue -> SocketResponse
DLVal (DLValue -> IO Response) -> DLValue -> IO Response
forall a b. (a -> b) -> a -> b
$ (forall a. a) -> DLValue
DLValue (Any -> a
forall a b. a -> b
unsafeCoerce Any
hval)
   OpenFileAsSocket String
name String
mode -> do
     CString
cname <- String -> IO CString
marshallString String
name
     CString
cmode <- String -> IO CString
marshallString String
mode
     Int
s <- String -> (Int -> Bool) -> IO Int -> IO Int
forall b. String -> (b -> Bool) -> IO b -> IO b
tryP String
"OpenSocketAsFile[fopen]" (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/=Int
0) (IO Int -> IO Int) -> IO Int -> IO Int
forall a b. (a -> b) -> a -> b
$ CString -> CString -> IO Int
fopen CString
cname CString
cmode
     CString -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CString
cname
     CString -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CString
cmode
     SocketResponse -> IO Response
returnS (SocketResponse -> IO Response) -> SocketResponse -> IO Response
forall a b. (a -> b) -> a -> b
$ (Socket -> SocketResponse
Socket (Socket -> SocketResponse)
-> (Int -> Socket) -> Int -> SocketResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Socket
So) Int
s
   SocketRequest
_ -> String -> IO Response
forall a. HasCallStack => String -> a
error (String
"Not implemented: "String -> ShowS
forall a. [a] -> [a] -> [a]
++SocketRequest -> String
forall a. Show a => a -> String
show SocketRequest
sr)
 where returnS :: SocketResponse -> IO Response
returnS = Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response)
-> (SocketResponse -> Response) -> SocketResponse -> IO Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SocketResponse -> Response
SocketResponse
       close :: Int -> IO Response
close Int
s = do
          Int -> IO Int
fclose Int
s
	  Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
Success
       socketname :: Int -> IO Response
socketname Int
s =
          (Addr -> IO Response) -> IO Response
forall c. (Addr -> IO c) -> IO c
allocaInt ((Addr -> IO Response) -> IO Response)
-> (Addr -> IO Response) -> IO Response
forall a b. (a -> b) -> a -> b
$ \ Addr
lenp ->
          do CsockAddr
sa <- IO CsockAddr
newsockAddr
--	     tryP "GetLSocketName" (==0) $ _ccall_ GETSOCKNAME (s::Int) sa lenp
	     String -> (Int -> Bool) -> IO Int -> IO Int
forall b. String -> (b -> Bool) -> IO b -> IO b
tryP String
"GetLSocketName" (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0) (IO Int -> IO Int) -> IO Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int -> CsockAddr -> Addr -> IO Int
getsockname Int
s CsockAddr
sa Addr
lenp
	     Int
len <- Addr -> IO Int
forall a. Storable a => Addr -> IO a
peek Addr
lenp
	     CString
strp <- GETC(sockAddr,char *,CString,sa,sa_data)
--	     Str . unpackPS <$> (stToIO $ packCBytesST len strp)
	     String -> Response
Str (String -> Response) -> IO String -> IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CString -> Int -> IO String
unmarshallString' CString
strp Int
len

writeSocket :: Socket -> String -> IO Response
writeSocket (So Int
s) String
str =
   do let n :: Int
n = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str
      Fd
fd <- Int -> IO Fd
get_fileno Int
s
      CString
cstr <- String -> Int -> IO CString
marshallString' String
str Int
n
      String -> (CSize -> Bool) -> IO CSize -> IO CSize
forall b. String -> (b -> Bool) -> IO b -> IO b
tryP String
"WriteSocket[out]" (CSize -> CSize -> Bool
forall a. Ord a => a -> a -> Bool
>=CSize
0) (IO CSize -> IO CSize) -> IO CSize -> IO CSize
forall a b. (a -> b) -> a -> b
$ 
--        _casm_ ``%r=write(fileno((FILE*)%0),%1,%2);'' s cstr n
        Fd -> CString -> CSize -> IO CSize
cwrite Fd
fd CString
cstr (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
      CString -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CString
cstr
      Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
Success

foreign import ccall "sys/socket.h" getsockname :: Int -> CsockAddr -> Addr -> IO Int
foreign import ccall "stdio.h" fdopen :: Int32 -> CString -> IO Int

getfilep :: Fd -> String -> IO Int
getfilep Fd
s String
mode = String -> (Int -> Bool) -> IO Int -> IO Int
forall b. String -> (b -> Bool) -> IO b -> IO b
tryP String
"fdopen" (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/=Int
0) (IO Int -> IO Int) -> IO Int -> IO Int
forall a b. (a -> b) -> a -> b
$
  do CString
cmode <- String -> IO CString
marshallString (String
mode::String)
--     _ccall_ fdopen (s::Int) cmode :: IO Int
     Fd -> CString -> IO Int
fdopen Fd
s CString
cmode :: IO Int

foreign import ccall "string.h strerror" cstrerror :: Int -> IO CString
strerror :: Int -> IO String
strerror Int
e = CString -> IO String
unmarshallString (CString -> IO String) -> IO CString -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> IO CString
cstrerror Int
e

tryP :: String -> (b -> Bool) -> IO b -> IO b
tryP String
e b -> Bool
p IO b
io = do
    b
r <- IO b
io
    if b -> Bool
p (b
r{-::Int-}) then b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
r else do
--      cstr <- _casm_ ``%r=strerror(errno);''
      String
s <- Int -> IO String
strerror (Int -> IO String) -> IO Int -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Int
errno
      String -> IO b
forall a. String -> IO a
failu (String
eString -> ShowS
forall a. [a] -> [a] -> [a]
++String
": "String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s)


peekq :: IORef (PQueue a b) -> IO (Maybe ((a, b), PQueue a b))
peekq IORef (PQueue a b)
tq = do
   PQueue a b
tqv <- IORef (PQueue a b) -> IO (PQueue a b)
forall a. IORef a -> IO a
readIOVar IORef (PQueue a b)
tq
   Maybe ((a, b), PQueue a b) -> IO (Maybe ((a, b), PQueue a b))
forall (m :: * -> *) a. Monad m => a -> m a
return (PQueue a b -> Maybe ((a, b), PQueue a b)
forall a b. PQueue a b -> Maybe ((a, b), PQueue a b)
inspect PQueue a b
tqv)

removetimeq :: IORef (PQueue a (a, b)) -> IO b
removetimeq IORef (PQueue a (a, b))
tq = do
   PQueue a (a, b)
tqv <- IORef (PQueue a (a, b)) -> IO (PQueue a (a, b))
forall a. IORef a -> IO a
readIOVar IORef (PQueue a (a, b))
tq
   case PQueue a (a, b) -> Maybe ((a, (a, b)), PQueue a (a, b))
forall a b. PQueue a b -> Maybe ((a, b), PQueue a b)
inspect PQueue a (a, b)
tqv of
     Just ((a
first,v :: (a, b)
v@(a
interval,b
tnov)),PQueue a (a, b)
tqv') -> do
        let tqv2 :: PQueue a (a, b)
tqv2 = if a
interval a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 then PQueue a (a, b)
tqv'
	           else PQueue a (a, b) -> (a, (a, b)) -> PQueue a (a, b)
forall a b. Ord a => PQueue a b -> (a, b) -> PQueue a b
insert PQueue a (a, b)
tqv' (a
firsta -> a -> a
forall a. Num a => a -> a -> a
+a
interval,(a, b)
v)
        IORef (PQueue a (a, b)) -> PQueue a (a, b) -> IO ()
forall a. IORef a -> a -> IO ()
writeIOVar IORef (PQueue a (a, b))
tq PQueue a (a, b)
tqv2
	b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
tnov
	
foreign import ccall "sys/time.h" gettimeofday :: CtimeVal -> Addr -> IO ()

mstime :: IO Int
mstime = do
    CtimeVal
now <- IO CtimeVal
newtimeVal
--    _casm_ ``gettimeofday(%0,NULL);'' now
    CtimeVal -> Addr -> IO ()
gettimeofday CtimeVal
now Addr
nullAddr
    Int
s <- GET(timeVal,Int,now,tv_sec)
    Int
us <- GET(timeVal,Int,now,tv_usec)
    Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
us Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
1000 :: Int)


foreign import ccall "asyncinput.h" fdzero :: Cfd_set -> IO ()
foreign import ccall "asyncinput.h fdset" fd_set :: Fd -> Cfd_set -> IO ()
foreign import ccall "asyncinput.h fdisset" fd_isset :: Fd -> Cfd_set -> IO Int
foreign import ccall "asyncinput.h" bcopy_fdset :: Cfd_set -> Cfd_set -> IO ()

doSelect :: XCallState -> [Descriptor] -> IO Response
doSelect :: XCallState -> [Descriptor] -> IO Response
doSelect (XCallState Cfd_set
fds IOVar Fd
maxfdvar IOVar AiTable
aitable IOVar (PQueue Int (Int, Timer))
_ IOVar Int
_) [Descriptor]
dl =
 do
  Cfd_set -> IO ()
fdzero Cfd_set
fds
  AiTable
ait <- [AiTable] -> AiTable
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([AiTable] -> AiTable) -> IO [AiTable] -> IO AiTable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Descriptor -> IO AiTable) -> [Descriptor] -> IO [AiTable]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Descriptor -> IO AiTable
descriptor [Descriptor]
dl
  let fds :: [Fd]
fds = ((Fd, Descriptor) -> Fd) -> AiTable -> [Fd]
forall a b. (a -> b) -> [a] -> [b]
map (Fd, Descriptor) -> Fd
forall a b. (a, b) -> a
fst AiTable
ait
  IOVar AiTable -> AiTable -> IO ()
forall a. IORef a -> a -> IO ()
writeIOVar IOVar AiTable
aitable AiTable
ait
  IOVar Fd -> Fd -> IO ()
forall a. IORef a -> a -> IO ()
writeIOVar IOVar Fd
maxfdvar ([Fd] -> Fd
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Fd]
fds)
  (Fd -> IO ()) -> [Fd] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Fd -> IO ()
fdset [Fd]
fds
  Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
Success
 where descriptor :: Descriptor -> IO AiTable
descriptor Descriptor
d = case Descriptor
d of
	   LSocketDe (LSo Int
s) -> IO Fd -> IO AiTable
forall (m :: * -> *) a. Monad m => m a -> m [(a, Descriptor)]
withd (IO Fd -> IO AiTable) -> IO Fd -> IO AiTable
forall a b. (a -> b) -> a -> b
$ Int -> IO Fd
get_fileno Int
s
	   SocketDe (So Int
s) ->  IO Fd -> IO AiTable
forall (m :: * -> *) a. Monad m => m a -> m [(a, Descriptor)]
withd (IO Fd -> IO AiTable) -> IO Fd -> IO AiTable
forall a b. (a -> b) -> a -> b
$ Int -> IO Fd
get_fileno Int
s
	   OutputSocketDe (So Int
s) ->  IO Fd -> IO AiTable
forall (m :: * -> *) a. Monad m => m a -> m [(a, Descriptor)]
withd (IO Fd -> IO AiTable) -> IO Fd -> IO AiTable
forall a b. (a -> b) -> a -> b
$ Int -> IO Fd
get_fileno Int
s
	   DisplayDe ({-Display-} Display
d) -> IO Fd -> IO AiTable
forall (m :: * -> *) a. Monad m => m a -> m [(a, Descriptor)]
withd (IO Fd -> IO AiTable) -> IO Fd -> IO AiTable
forall a b. (a -> b) -> a -> b
$ 
--	         _casm_ ``%r=((Display*)%0)->fd;'' d
		 Display -> IO Fd
xConnectionNumber Display
d -- hmm
	   TimerDe Timer
_ -> AiTable -> IO AiTable
forall (m :: * -> *) a. Monad m => a -> m a
return []
           Descriptor
_ -> do String -> IO ()
putStr String
"Unexpected descriptor: ";Descriptor -> IO ()
forall a. Show a => a -> IO ()
print Descriptor
d;AiTable -> IO AiTable
forall (m :: * -> *) a. Monad m => a -> m a
return []
          where withd :: m a -> m [(a, Descriptor)]
withd m a
m = m a
m m a -> (a -> m [(a, Descriptor)]) -> m [(a, Descriptor)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
fd -> [(a, Descriptor)] -> m [(a, Descriptor)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(a
fd,Descriptor
d)]

       fdset :: Fd -> IO ()
       --fdset s =  _casm_ ``FD_SET(%0,(fd_set*)%1);'' s fds
       fdset :: Fd -> IO ()
fdset Fd
s =  Fd -> Cfd_set -> IO ()
fd_set Fd
s Cfd_set
fds

foreign import ccall "asyncinput.h" get_fileno :: Int -> IO Fd
{-

-- Register problems with FD_ZERO under Redhat 6.1 Linux-i386...
--fdzero :: Cfd_set -> IO ()
--fdzero fds = _casm_ ``{ fd_set *s=%0; FD_ZERO(s);}'' fds
--fdzero fds = _ccall_ FD_ZERO fds

mutByteArr2Addr :: MutableByteArray RealWorld Int -> IO  Addr
mutByteArr2Addr arr  = _casm_ `` %r=(void *)%0; '' arr
--}

foreign import ccall "unistd.h" fork :: IO Int
foreign import ccall "unistd.h" execl :: CString -> CString -> CString -> CString -> Int -> IO Int
foreign import ccall "unistd.h" pipe :: Addr -> IO Int
foreign import ccall "unistd.h" dup :: Fd -> IO Fd
foreign import ccall "asyncinput.h" disable_timers :: IO ()

startProcess :: String -> Bool -> Bool -> Bool -> IO Response
startProcess String
cmd Bool
doIn Bool
doOut Bool
doErr =
  do Maybe (Fd, Fd)
inPipe <- Bool -> IO (Maybe (Fd, Fd))
optPipe Bool
doIn
     Maybe (Fd, Fd)
outPipe <- Bool -> IO (Maybe (Fd, Fd))
optPipe Bool
doOut
     Maybe (Fd, Fd)
errPipe <- Bool -> IO (Maybe (Fd, Fd))
optPipe Bool
doErr
--     pid <- _ccall_ fork
     Int
pid <- IO Int
fork
     case Int
pid::Int of
       -1 -> String -> IO Response
forall a. String -> IO a
failu String
"fork" -- use tryP instead
       Int
0 -> do -- child process
	       -- Disable virtual timer, used by the GHC RTS
	       IO ()
disable_timers
	       Fd -> Maybe (Fd, Fd) -> IO ()
optDupIn Fd
0 Maybe (Fd, Fd)
inPipe
	       Fd -> Maybe (Fd, Fd) -> IO ()
optDupOut Fd
1 Maybe (Fd, Fd)
outPipe
	       Fd -> Maybe (Fd, Fd) -> IO ()
optDupOut Fd
2 Maybe (Fd, Fd)
errPipe
	       CString
binsh <- String -> IO CString
marshallString String
"/bin/sh"
	       CString
sh <- String -> IO CString
marshallString String
"sh"
	       CString
dashc <- String -> IO CString
marshallString String
"-c"
	       CString
ccmd <- String -> IO CString
marshallString String
cmd
	       CString -> CString -> CString -> CString -> Int -> IO Int
execl CString
binsh CString
sh CString
dashc CString
ccmd (Int
0::Int)
	       --_ccall_ _exit 1
	       String -> IO Response
forall a. String -> IO a
failu String
"execl"
       Int
_ -> do -- parent process
	       Maybe Socket
inS <- Maybe (Fd, Fd) -> IO (Maybe Socket)
optPipeIn Maybe (Fd, Fd)
inPipe
	       Maybe Socket
outS <- Maybe (Fd, Fd) -> IO (Maybe Socket)
optPipeOut Maybe (Fd, Fd)
outPipe
	       Maybe Socket
errS <- Maybe (Fd, Fd) -> IO (Maybe Socket)
optPipeOut Maybe (Fd, Fd)
errPipe
	       Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ SocketResponse -> Response
SocketResponse (SocketResponse -> Response) -> SocketResponse -> Response
forall a b. (a -> b) -> a -> b
$ Maybe Socket -> Maybe Socket -> Maybe Socket -> SocketResponse
ProcessSockets Maybe Socket
inS Maybe Socket
outS Maybe Socket
errS
  where
    optPipe :: Bool -> IO (Maybe (Fd, Fd))
optPipe Bool
False = Maybe (Fd, Fd) -> IO (Maybe (Fd, Fd))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Fd, Fd)
forall a. Maybe a
Nothing
    optPipe Bool
True = (Fd, Fd) -> Maybe (Fd, Fd)
forall a. a -> Maybe a
Just ((Fd, Fd) -> Maybe (Fd, Fd)) -> IO (Fd, Fd) -> IO (Maybe (Fd, Fd))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO (Fd, Fd)
newPipe
    newPipe :: IO (Fd, Fd)
newPipe = do CInt32
pa <- Int -> IO CInt32
forall a. IsPtr a => Int -> IO a
newArray Int
2
		 Int
ok <- Addr -> IO Int
pipe (CInt32 -> Addr
forall a. HasAddr a => a -> Addr
addrOf (CInt32
pa::CInt32))
		 [Fd
p0,Fd
p1] <- CInt32 -> Int -> IO [Fd]
forall c h. CVar c h => c -> Int -> IO [h]
readArray CInt32
pa Int
2
		 CInt32 -> IO ()
forall a. HasAddr a => a -> IO ()
freePtr CInt32
pa
		 Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
okInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/=Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. String -> IO a
failu String
"pipe" -- use tryP instead
		 (Fd, Fd) -> IO (Fd, Fd)
forall (m :: * -> *) a. Monad m => a -> m a
return (Fd
p0,Fd
p1)

    optDupIn :: Fd -> Maybe (Fd, Fd) -> IO ()
optDupIn Fd
d = Fd -> Maybe (Fd, Fd) -> IO ()
optDupOut Fd
d (Maybe (Fd, Fd) -> IO ())
-> (Maybe (Fd, Fd) -> Maybe (Fd, Fd)) -> Maybe (Fd, Fd) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Fd, Fd) -> (Fd, Fd)) -> Maybe (Fd, Fd) -> Maybe (Fd, Fd)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Fd, Fd) -> (Fd, Fd)
forall b a. (b, a) -> (a, b)
swap
    optDupOut :: Fd -> Maybe (Fd, Fd) -> IO ()
optDupOut Fd
d = IO () -> ((Fd, Fd) -> IO ()) -> Maybe (Fd, Fd) -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Fd -> (Fd, Fd) -> IO ()
dupOut Fd
d)
    dupOut :: Fd -> (Fd, Fd) -> IO ()
dupOut Fd
d (Fd
p0,Fd
p1) = do Fd -> IO Fd
cclose Fd
d
			  Fd -> IO Fd
dup Fd
p1
			  Fd -> IO Fd
cclose Fd
p0
			  Fd -> IO Fd
cclose Fd
p1
			  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    optPipeIn :: Maybe (Fd, Fd) -> IO (Maybe Socket)
optPipeIn = String -> Maybe (Fd, Fd) -> IO (Maybe Socket)
optPipeS String
"w" (Maybe (Fd, Fd) -> IO (Maybe Socket))
-> (Maybe (Fd, Fd) -> Maybe (Fd, Fd))
-> Maybe (Fd, Fd)
-> IO (Maybe Socket)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Fd, Fd) -> (Fd, Fd)) -> Maybe (Fd, Fd) -> Maybe (Fd, Fd)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Fd, Fd) -> (Fd, Fd)
forall b a. (b, a) -> (a, b)
swap
    optPipeOut :: Maybe (Fd, Fd) -> IO (Maybe Socket)
optPipeOut = String -> Maybe (Fd, Fd) -> IO (Maybe Socket)
optPipeS String
"r"
    optPipeS :: String -> Maybe (Fd, Fd) -> IO (Maybe Socket)
optPipeS String
m = IO (Maybe Socket)
-> ((Fd, Fd) -> IO (Maybe Socket))
-> Maybe (Fd, Fd)
-> IO (Maybe Socket)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Socket -> IO (Maybe Socket)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Socket
forall a. Maybe a
Nothing) ((Socket -> Maybe Socket) -> IO Socket -> IO (Maybe Socket)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Socket -> Maybe Socket
forall a. a -> Maybe a
Just (IO Socket -> IO (Maybe Socket))
-> ((Fd, Fd) -> IO Socket) -> (Fd, Fd) -> IO (Maybe Socket)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (Fd, Fd) -> IO Socket
pipeS String
m)
    pipeS :: String -> (Fd, Fd) -> IO Socket
pipeS String
m (Fd
p0,Fd
p1) = do Fd -> IO Fd
cclose Fd
p1
			 (Int -> Socket) -> IO Int -> IO Socket
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Socket
So (Fd -> String -> IO Int
getfilep Fd
p0 String
m)
			 

foreign import ccall "unistd.h close" cclose :: Int32 -> IO Int32