{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
module AsyncInput
(doSocketRequest,doSelect,getAsyncInput',initXCall,XCallState)
where
import P_IO_data(Response(..))
import Xtypes
import Sockets as S
import DLValue
import Unsafe.Coerce
import Utils(swap)
import XCallTypes
import StructFuns
import Xlib
import EncodeEvent
import Marshall
import MyForeign
import GHC.Exts(addrToAny# )
import GHC.Ptr(FunPtr(..))
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
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
(IOVar Fd)
(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
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
<$>
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
$
Fd -> CsockAddr -> Addr -> IO Fd
accept Fd
fd CsockAddr
addr Addr
addrlen
Int
sf <- Fd -> String -> IO Int
getfilep Fd
sfd String
"r+"
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) <- 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
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)
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)
then IO Fd
start
else forall (m :: * -> *) a. Monad m => a -> m a
return Fd
n
foreign import ccall "asyncinput.h get_errno" errno :: IO Int
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
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
$
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 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 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
SocketResponse -> IO Response
returnS (Int -> SocketResponse
Wrote (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str))
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
<$>
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
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)
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
$
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)
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) then forall (m :: * -> *) a. Monad m => a -> m a
return b
r else do
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
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
d) -> forall {m :: * -> *} {a}. Monad m => m a -> m [(a, Descriptor)]
withd forall a b. (a -> b) -> a -> b
$
Display -> IO Fd
xConnectionNumber Display
d
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 :: 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
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
Int
pid <- IO Int
fork
case Int
pid::Int of
-1 -> forall a. String -> IO a
failu String
"fork"
Int
0 -> do
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)
forall a. String -> IO a
failu String
"execl"
Int
_ -> do
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"
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