{-# 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
import PackedString(unpackPS,lengthPS)
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
(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
(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
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
<$>
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
$
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
""
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) <- 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
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)
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)
then IO Fd
start
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
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 <- 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
$
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 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 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)
SocketResponse -> IO Response
returnS (Int -> SocketResponse
Wrote (PackedString -> Int
lengthPS PackedString
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 (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
<$>
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
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)
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
$
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)
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) then b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
r else do
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
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
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
$
Display -> IO Fd
xConnectionNumber Display
d
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 :: 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 -> String -> IO Response
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)
String -> IO Response
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
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"
(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