{-# 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 = 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 = forall a. a -> IO (IORef a)
newIORef
readIOVar :: IORef a -> IO a
readIOVar = forall a. IORef a -> IO a
readIORef
writeIOVar :: IORef a -> a -> IO ()
writeIOVar = 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
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IsPtr a => IO a
newPtr
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (IORef a)
newIOVar Fd
0
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (IORef a)
newIOVar []
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (IORef a)
newIOVar forall {a} {b}. PQueue a b
empty
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
   AiTable
ai <- forall a. IORef a -> IO a
readIOVar IOVar AiTable
aitable
   let timeLeft :: IO (Maybe Int)
timeLeft =
	  do PQueue Int (Int, Timer)
tqv <- forall a. IORef a -> IO a
readIOVar IOVar (PQueue Int (Int, Timer))
tq
	     case 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
	       Just ((Int
t,(Int, Timer)
_),PQueue Int (Int, Timer)
_) ->
		 do Int
ms <- IO Int
mstime
		    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
max Int
0 forall a b. (a -> b) -> a -> b
$ Int
t forall a. Num a => a -> a -> a
- Int
ms
   
   let doSelect :: IO AsyncInput
doSelect = do
	  Maybe CtimeVal
timeout <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Int -> IO CtimeVal
newTimeVal forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Maybe Int)
timeLeft
          Cfd_set
readfds <- 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 <- forall a. IORef a -> IO a
readIOVar IOVar Fd
maxfdvar
	  Fd
n <- Fd -> Cfd_set -> Maybe CtimeVal -> IO Fd
select (Fd
maxfdvarforall a. Num a => a -> a -> a
+Fd
1) Cfd_set
readfds Maybe CtimeVal
timeout
	  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall {a}. HasAddr a => a -> IO ()
freePtr Maybe CtimeVal
timeout
	  let findFd :: Fd -> IO AsyncInput
findFd Fd
fd = do
		  Bool
s <- forall a. FromC a => Int -> a
fromC 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
fdforall 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
_ -> forall {p}. p -> Descriptor -> IO AsyncInput
mkEvent Fd
fd Descriptor
d
		       SocketDe Socket
_ ->
		         let bufsize :: Int
bufsize = Int
2000
			 in forall {c}. Int -> (Addr -> IO c) -> IO c
alloca Int
bufsize forall a b. (a -> b) -> a -> b
$ \ Addr
buf ->
			 do CSize
got <- forall {b}. String -> (b -> Bool) -> IO b -> IO b
tryP String
"read" (forall a. Ord a => a -> a -> Bool
>=CSize
0) forall a b. (a -> b) -> a -> b
$ Fd -> Addr -> CSize -> IO CSize
cread Fd
fd Addr
buf (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bufsize)
			    String
str <- CString -> Int -> IO String
unmarshallString' (Addr -> CString
CString Addr
buf) (forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
got)
			    forall (m :: * -> *) a. Monad m => a -> m a
return (Descriptor
d,String -> AEvent
SocketRead String
str)
#ifdef VERSION_bytestring
		       BinSocketDe Socket
_ ->
		         let bufsize :: Int
bufsize = Int
2000
			 in forall {c}. Int -> (Addr -> IO c) -> IO c
alloca Int
bufsize forall a b. (a -> b) -> a -> b
$ \ Addr
buf ->
			 do CSize
got <- forall {b}. String -> (b -> Bool) -> IO b -> IO b
tryP String
"read" (forall a. Ord a => a -> a -> Bool
>=CSize
0) forall a b. (a -> b) -> a -> b
$ Fd -> Addr -> CSize -> IO CSize
cread Fd
fd Addr
buf (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bufsize)
			    ByteString
bs <- CString -> Int -> IO ByteString
unmarshallByteString' (Addr -> CString
CString Addr
buf) (forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
got)
			    forall (m :: * -> *) a. Monad m => a -> m a
return (Descriptor
d,ByteString -> AEvent
SocketReadBin ByteString
bs)
#endif
		       LSocketDe LSocket
_ ->
		         forall {c}. (Addr -> IO c) -> IO c
allocaInt forall a b. (a -> b) -> a -> b
$ \ Addr
addrlen ->
			 do CsockAddr
addr <- IO CsockAddr
newsockAddr
			    Fd
sfd <- forall {b}. String -> (b -> Bool) -> IO b -> IO b
tryP String
"accept" (forall a. Ord a => a -> a -> Bool
>=Fd
0) 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
""
			    forall (m :: * -> *) a. Monad m => a -> m a
return (Descriptor
d,Socket -> String -> AEvent
SocketAccepted (Int -> Socket
So Int
sf) String
peer)

		       Descriptor
_ -> forall a. HasCallStack => String -> a
error String
"getAsyncInput3"
          AsyncInput
e <- if Fd
n forall a. Eq a => a -> a -> Bool
== -Fd
1 then forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"select "forall a. [a] -> [a] -> [a]
++) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> IO String
strerror forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Int
errno
	       else if Fd
n forall a. Ord a => a -> a -> Bool
> Fd
0 then Fd -> IO AsyncInput
findFd Fd
0
	            else do Timer
tno <- forall {a} {b}. (Num a, Ord a) => IORef (PQueue a (a, b)) -> IO b
removetimeq IOVar (PQueue Int (Int, Timer))
tq
	                    forall (m :: * -> *) a. Monad m => a -> m a
return (Timer -> Descriptor
TimerDe Timer
tno,AEvent
TimerAlarm)
	  forall {a}. HasAddr a => a -> IO ()
freePtr Cfd_set
readfds
	  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
	   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 = forall a b. Eq a => [(a, b)] -> b -> a -> b
lookupWithDefault AiTable
ai (forall a. HasCallStack => String -> a
error String
"getAsyncInput2")
       dispde :: (a, Descriptor) -> Maybe (a, Descriptor)
dispde x :: (a, Descriptor)
x@(a
fd,DisplayDe Display
_) = forall a. a -> Maybe a
Just (a, Descriptor)
x
       dispde (a, Descriptor)
_ = forall a. Maybe a
Nothing
   case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe 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
qforall a. Ord a => a -> a -> Bool
>Int
0 then 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 <- 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))
     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 forall a. IsPtr a => a
nullPtr forall a. IsPtr a => a
nullPtr (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. IsPtr a => a
nullPtr 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 forall a. Eq a => a -> a -> Bool
/= -Fd
1 then forall (m :: * -> *) a. Monad m => a -> m a
return Fd
n else do
       Int
e <- IO Int
errno
       if Int
e forall a. Eq a => a -> a -> Bool
== CCONST(EINTR) --- || e == CCONST(EAGAIN)
         then IO Fd
start -- again
         else 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 <- forall a. IORef a -> IO a
readIOVar IOVar (PQueue Int (Int, Timer))
tq
          Int
tnov <- forall a. IORef a -> IO a
readIOVar IOVar Int
tno
	  Int
now <- IO Int
mstime
	  forall a. IORef a -> a -> IO ()
writeIOVar IOVar (PQueue Int (Int, Timer))
tq (forall {a} {b}. Ord a => PQueue a b -> (a, b) -> PQueue a b
insert PQueue Int (Int, Timer)
tqv (Int
nowforall a. Num a => a -> a -> a
+Int
first,(Int
interval,Int -> Timer
Ti Int
tnov)))
	  forall a. IORef a -> a -> IO ()
writeIOVar IOVar Int
tno (Int
tnovforall 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 <- forall a. IORef a -> IO a
readIOVar IOVar (PQueue Int (Int, Timer))
tq
	  forall a. IORef a -> a -> IO ()
writeIOVar IOVar (PQueue Int (Int, Timer))
tq (forall {a1} {a2} {a3}.
Eq a1 =>
PQueue a2 (a3, a1) -> a1 -> PQueue a2 (a3, a1)
remove PQueue Int (Int, Timer)
tqv Timer
t)
	  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 <- forall {b}. String -> (b -> Bool) -> IO b -> IO b
tryP String
"in_connect" (forall a. Ord a => a -> a -> Bool
>=Fd
0) 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port) (forall a b. (Integral a, Num b) => a -> b
fromIntegral CCONST(SOCK_STREAM))
     Int
sf <- Fd -> String -> IO Int
getfilep Fd
s String
"r+"
     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 <- forall {b}. String -> (b -> Bool) -> IO b -> IO b
tryP String
"in_bind" (forall a. Ord a => a -> a -> Bool
>=Fd
0) forall a b. (a -> b) -> a -> b
$ if Int
port 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 (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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port) (forall a b. (Integral a, Num b) => a -> b
fromIntegral CCONST(SOCK_STREAM))
      forall {b}. String -> (b -> Bool) -> IO b -> IO b
tryP String
"listen" (forall a. Eq a => a -> a -> Bool
==Int
0) forall a b. (a -> b) -> a -> b
$ Fd -> Fd -> IO Int
listen Fd
s Fd
5
      SocketResponse -> Response
SocketResponse forall b c a. (b -> c) -> (a -> b) -> a -> c
. LSocket -> SocketResponse
LSocket forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> LSocket
LSo 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 String
str ->
      do Socket -> String -> IO Response
writeSocket Socket
s String
str -- grr!
         SocketResponse -> IO Response
returnS (Int -> SocketResponse
Wrote (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> SocketResponse
Socket forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Socket
So 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 -> forall a. String -> IO a
failu forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String
dlerror
                       DL
_ -> SocketResponse -> IO Response
returnS 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 ; forall (m :: * -> *) a. Monad m => a -> m a
return Response
Success
   DLSym (DL DL
dh) String
name ->
       do FunPtr Addr#
fp <- forall a. DL -> String -> IO (FunPtr a)
dlsym DL
dh String
name
          case forall a. Addr# -> (# a #)
addrToAny# Addr#
fp of
            (# Any
hval #) -> SocketResponse -> IO Response
returnS forall b c a. (b -> c) -> (a -> b) -> a -> c
. DLValue -> SocketResponse
DLVal forall a b. (a -> b) -> a -> b
$ (forall a. a) -> DLValue
DLValue (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 <- forall {b}. String -> (b -> Bool) -> IO b -> IO b
tryP String
"OpenSocketAsFile[fopen]" (forall a. Eq a => a -> a -> Bool
/=Int
0) forall a b. (a -> b) -> a -> b
$ CString -> CString -> IO Int
fopen CString
cname CString
cmode
     forall {a}. HasAddr a => a -> IO ()
freePtr CString
cname
     forall {a}. HasAddr a => a -> IO ()
freePtr CString
cmode
     SocketResponse -> IO Response
returnS forall a b. (a -> b) -> a -> b
$ (Socket -> SocketResponse
Socket forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Socket
So) Int
s
   SocketRequest
_ -> forall a. HasCallStack => String -> a
error (String
"Not implemented: "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show SocketRequest
sr)
 where returnS :: SocketResponse -> IO Response
returnS = forall (m :: * -> *) a. Monad m => a -> m a
return 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
	  forall (m :: * -> *) a. Monad m => a -> m a
return Response
Success
       socketname :: Int -> IO Response
socketname Int
s =
          forall {c}. (Addr -> IO c) -> IO c
allocaInt forall a b. (a -> b) -> a -> b
$ \ Addr
lenp ->
          do CsockAddr
sa <- IO CsockAddr
newsockAddr
--	     tryP "GetLSocketName" (==0) $ _ccall_ GETSOCKNAME (s::Int) sa lenp
	     forall {b}. String -> (b -> Bool) -> IO b -> IO b
tryP String
"GetLSocketName" (forall a. Eq a => a -> a -> Bool
==Int
0) forall a b. (a -> b) -> a -> b
$ Int -> CsockAddr -> Addr -> IO Int
getsockname Int
s CsockAddr
sa Addr
lenp
	     Int
len <- 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 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 = 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
      forall {b}. String -> (b -> Bool) -> IO b -> IO b
tryP String
"WriteSocket[out]" (forall a. Ord a => a -> a -> Bool
>=CSize
0) 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
      forall {a}. HasAddr a => a -> IO ()
freePtr CString
cstr
      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 = forall {b}. String -> (b -> Bool) -> IO b -> IO b
tryP String
"fdopen" (forall a. Eq a => a -> a -> Bool
/=Int
0) 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 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 forall (m :: * -> *) a. Monad m => a -> m a
return b
r else do
--      cstr <- _casm_ ``%r=strerror(errno);''
      String
s <- Int -> IO String
strerror forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Int
errno
      forall a. String -> IO a
failu (String
eforall a. [a] -> [a] -> [a]
++String
": "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 <- forall a. IORef a -> IO a
readIOVar IORef (PQueue a b)
tq
   forall (m :: * -> *) a. Monad m => a -> m a
return (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 <- forall a. IORef a -> IO a
readIOVar IORef (PQueue a (a, b))
tq
   case 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 forall a. Eq a => a -> a -> Bool
== a
0 then PQueue a (a, b)
tqv'
	           else forall {a} {b}. Ord a => PQueue a b -> (a, b) -> PQueue a b
insert PQueue a (a, b)
tqv' (a
firstforall a. Num a => a -> a -> a
+a
interval,(a, b)
v)
        forall a. IORef a -> a -> IO ()
writeIOVar IORef (PQueue a (a, b))
tq PQueue a (a, b)
tqv2
	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)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Int
s forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
+ Int
us 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 <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst AiTable
ait
  forall a. IORef a -> a -> IO ()
writeIOVar IOVar AiTable
aitable AiTable
ait
  forall a. IORef a -> a -> IO ()
writeIOVar IOVar Fd
maxfdvar (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Fd]
fds)
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Fd -> IO ()
fdset [Fd]
fds
  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) -> forall {m :: * -> *} {a}. Monad m => m a -> m [(a, Descriptor)]
withd forall a b. (a -> b) -> a -> b
$ Int -> IO Fd
get_fileno Int
s
	   SocketDe (So Int
s) ->  forall {m :: * -> *} {a}. Monad m => m a -> m [(a, Descriptor)]
withd forall a b. (a -> b) -> a -> b
$ Int -> IO Fd
get_fileno Int
s
	   BinSocketDe (So Int
s) ->  forall {m :: * -> *} {a}. Monad m => m a -> m [(a, Descriptor)]
withd forall a b. (a -> b) -> a -> b
$ Int -> IO Fd
get_fileno Int
s
	   OutputSocketDe (So Int
s) ->  forall {m :: * -> *} {a}. Monad m => m a -> m [(a, Descriptor)]
withd forall a b. (a -> b) -> a -> b
$ Int -> IO Fd
get_fileno Int
s
	   DisplayDe ({-Display-} Display
d) -> forall {m :: * -> *} {a}. Monad m => m a -> m [(a, Descriptor)]
withd forall a b. (a -> b) -> a -> b
$ 
--	         _casm_ ``%r=((Display*)%0)->fd;'' d
		 Display -> IO Fd
xConnectionNumber Display
d -- hmm
	   TimerDe Timer
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []
           Descriptor
_ -> do String -> IO ()
putStr String
"Unexpected descriptor: ";forall a. Show a => a -> IO ()
print Descriptor
d;forall (m :: * -> *) a. Monad m => a -> m a
return []
          where withd :: m a -> m [(a, Descriptor)]
withd m a
m = m a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
fd -> 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 -> 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
	       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
	       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SocketResponse -> Response
SocketResponse 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    optPipe Bool
True = forall a. a -> Maybe a
Just 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 <- forall a. IsPtr a => Int -> IO a
newArray Int
2
		 Int
ok <- Addr -> IO Int
pipe (forall a. HasAddr a => a -> Addr
addrOf (CInt32
pa::CInt32))
		 [Fd
p0,Fd
p1] <- forall c h. CVar c h => c -> Int -> IO [h]
readArray CInt32
pa Int
2
		 forall {a}. HasAddr a => a -> IO ()
freePtr CInt32
pa
		 forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
okforall a. Eq a => a -> a -> Bool
/=Int
0) forall a b. (a -> b) -> a -> b
$ forall a. String -> IO a
failu String
"pipe" -- use tryP instead
		 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {b} {a}. (b, a) -> (a, b)
swap
    optDupOut :: Fd -> Maybe (Fd, Fd) -> IO ()
optDupOut Fd
d = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (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
			  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" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just 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
			 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