{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}

-- Copyright (C) 2009-2012 John Millikin <john@john-millikin.com>
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

-- | Support for defining custom transport mechanisms. Most users will not
-- need to care about the types defined in this module.
module DBus.Transport
    (
    -- * Transports
      Transport(..)
    , TransportOpen(..)
    , TransportListen(..)

    -- * Transport errors
    , TransportError
    , transportError
    , transportErrorMessage
    , transportErrorAddress

    -- * Socket transport
    , SocketTransport
    , socketTransportOptionBacklog
    , socketTransportCredentials
    ) where

import           Control.Concurrent (rtsSupportsBoundThreads, threadWaitWrite)
import           Control.Exception
import           Control.Monad (when)
import qualified Data.ByteString
import qualified Data.ByteString.Builder as Builder
import           Data.ByteString.Internal (ByteString(PS))
import qualified Data.ByteString.Lazy as Lazy
import           Data.ByteString.Unsafe (unsafeUseAsCString)
import qualified Data.Kind
import qualified Data.Map as Map
import           Data.Maybe (fromMaybe)
import           Data.Monoid
import           Data.Typeable (Typeable)
import           Foreign.C (CInt, CUInt)
import           Foreign.ForeignPtr (withForeignPtr)
import           Foreign.Marshal.Array (peekArray)
import           Foreign.Ptr (castPtr, plusPtr)
import           Foreign.Storable (sizeOf)
import           Network.Socket
import           Network.Socket.Address (SocketAddress(..))
import qualified Network.Socket.Address
import           Network.Socket.ByteString (recvMsg)
import qualified System.Info
import           System.IO.Unsafe (unsafeDupablePerformIO)
import           System.Posix.Types (Fd)
import           Prelude

import           DBus

-- | Thrown from transport methods when an error occurs.
data TransportError = TransportError
    { TransportError -> String
transportErrorMessage :: String
    , TransportError -> Maybe Address
transportErrorAddress :: Maybe Address
    }
    deriving (TransportError -> TransportError -> Bool
(TransportError -> TransportError -> Bool)
-> (TransportError -> TransportError -> Bool) -> Eq TransportError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TransportError -> TransportError -> Bool
== :: TransportError -> TransportError -> Bool
$c/= :: TransportError -> TransportError -> Bool
/= :: TransportError -> TransportError -> Bool
Eq, Int -> TransportError -> ShowS
[TransportError] -> ShowS
TransportError -> String
(Int -> TransportError -> ShowS)
-> (TransportError -> String)
-> ([TransportError] -> ShowS)
-> Show TransportError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TransportError -> ShowS
showsPrec :: Int -> TransportError -> ShowS
$cshow :: TransportError -> String
show :: TransportError -> String
$cshowList :: [TransportError] -> ShowS
showList :: [TransportError] -> ShowS
Show, Typeable)

instance Exception TransportError

transportError :: String -> TransportError
transportError :: String -> TransportError
transportError String
msg = String -> Maybe Address -> TransportError
TransportError String
msg Maybe Address
forall a. Maybe a
Nothing

-- | A 'Transport' can exchange bytes with a remote peer.
class Transport t where
    -- | Additional options that this transport type may use when establishing
    -- a connection.
    data TransportOptions t :: Data.Kind.Type

    -- | Default values for this transport's options.
    transportDefaultOptions :: TransportOptions t

    -- | Send a 'ByteString' over the transport.
    --
    -- Throws a 'TransportError' if an error occurs.
    transportPut :: t -> ByteString -> IO ()
    
    -- | Send a 'ByteString' and Unix file descriptors over the transport.
    --
    -- Throws a 'TransportError' if an error occurs.
    transportPutWithFds :: t -> ByteString -> [Fd] -> IO ()
    transportPutWithFds t
t ByteString
bs [Fd]
_fds = t -> ByteString -> IO ()
forall t. Transport t => t -> ByteString -> IO ()
transportPut t
t ByteString
bs

    -- | Receive a 'ByteString' of the given size from the transport. The
    -- transport should block until sufficient bytes are available, and
    -- only return fewer than the requested amount if there will not be
    -- any more data.
    --
    -- Throws a 'TransportError' if an error occurs.
    transportGet :: t -> Int -> IO ByteString

    -- | Receive a 'ByteString' of the given size from the transport, plus
    -- any Unix file descriptors that arrive with the byte data. The
    -- transport should block until sufficient bytes are available, and
    -- only return fewer than the requested amount if there will not be
    -- any more data.
    --
    -- Throws a 'TransportError' if an error occurs.
    transportGetWithFds :: t -> Int -> IO (ByteString, [Fd])
    transportGetWithFds t
t Int
n = do
        ByteString
bs <- t -> Int -> IO ByteString
forall t. Transport t => t -> Int -> IO ByteString
transportGet t
t Int
n
        (ByteString, [Fd]) -> IO (ByteString, [Fd])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
bs, [])

    -- | Close an open transport, and release any associated resources
    -- or handles.
    transportClose :: t -> IO ()

-- | A 'Transport' which can open a connection to a remote peer.
class Transport t => TransportOpen t where
    -- | Open a connection to the given address, using the given options.
    --
    -- Throws a 'TransportError' if the connection could not be
    -- established.
    transportOpen :: TransportOptions t -> Address -> IO t

-- | A 'Transport' which can listen for and accept connections from remote
-- peers.
class Transport t => TransportListen t where
    -- | Used for transports that listen on a port or address.
    data TransportListener t :: Data.Kind.Type

    -- | Begin listening for connections on the given address, using the
    -- given options.
    --
    -- Throws a 'TransportError' if it's not possible to listen at that
    -- address (for example, if the port is already in use).
    transportListen :: TransportOptions t -> Address -> IO (TransportListener t)

    -- | Accept a new connection.
    --
    -- Throws a 'TransportError' if some error happens before the
    -- transport is ready to exchange bytes.
    transportAccept :: TransportListener t -> IO t

    -- | Close an open listener.
    transportListenerClose :: TransportListener t -> IO ()

    -- | Get the address to use to connect to a listener.
    transportListenerAddress :: TransportListener t -> Address

    -- | Get the UUID allocated to this transport listener.
    --
    -- See 'randomUUID'.
    transportListenerUUID :: TransportListener t -> UUID

-- | Supports connecting over Unix or TCP sockets.
--
-- Unix sockets are similar to pipes, but exist as special files in the
-- filesystem. On Linux, /abstract sockets/ have a path-like address, but do
-- not actually have entries in the filesystem.
--
-- TCP sockets may use either IPv4 or IPv6.
data SocketTransport = SocketTransport (Maybe Address) Socket

instance Transport SocketTransport where
    data TransportOptions SocketTransport = SocketTransportOptions
        {
        -- | The maximum size of the connection queue for a listening
        -- socket.
          TransportOptions SocketTransport -> Int
socketTransportOptionBacklog :: Int
        }
    transportDefaultOptions :: TransportOptions SocketTransport
transportDefaultOptions = Int -> TransportOptions SocketTransport
SocketTransportOptions Int
30
    transportPut :: SocketTransport -> ByteString -> IO ()
transportPut SocketTransport
st ByteString
bytes = SocketTransport -> ByteString -> [Fd] -> IO ()
forall t. Transport t => t -> ByteString -> [Fd] -> IO ()
transportPutWithFds SocketTransport
st ByteString
bytes []
    transportPutWithFds :: SocketTransport -> ByteString -> [Fd] -> IO ()
transportPutWithFds (SocketTransport Maybe Address
addr Socket
s) ByteString
bytes [Fd]
fds = Maybe Address -> IO () -> IO ()
forall a. Maybe Address -> IO a -> IO a
catchIOException Maybe Address
addr (Socket -> ByteString -> [Fd] -> IO ()
sendWithFds Socket
s ByteString
bytes [Fd]
fds)
    transportGet :: SocketTransport -> Int -> IO ByteString
transportGet SocketTransport
st Int
n = (ByteString, [Fd]) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, [Fd]) -> ByteString)
-> IO (ByteString, [Fd]) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SocketTransport -> Int -> IO (ByteString, [Fd])
forall t. Transport t => t -> Int -> IO (ByteString, [Fd])
transportGetWithFds SocketTransport
st Int
n
    transportGetWithFds :: SocketTransport -> Int -> IO (ByteString, [Fd])
transportGetWithFds (SocketTransport Maybe Address
addr Socket
s) Int
n = Maybe Address -> IO (ByteString, [Fd]) -> IO (ByteString, [Fd])
forall a. Maybe Address -> IO a -> IO a
catchIOException Maybe Address
addr (Socket -> Int -> IO (ByteString, [Fd])
recvWithFds Socket
s Int
n)
    transportClose :: SocketTransport -> IO ()
transportClose (SocketTransport Maybe Address
addr Socket
s) = Maybe Address -> IO () -> IO ()
forall a. Maybe Address -> IO a -> IO a
catchIOException Maybe Address
addr (Socket -> IO ()
close Socket
s)

-- todo: import NullSockAddr from network package, when released
-- (https://github.com/haskell/network/pull/562)
data NullSockAddr = NullSockAddr

instance SocketAddress NullSockAddr where
    sizeOfSocketAddress :: NullSockAddr -> Int
sizeOfSocketAddress NullSockAddr
NullSockAddr = Int
0
    peekSocketAddress :: Ptr NullSockAddr -> IO NullSockAddr
peekSocketAddress Ptr NullSockAddr
_ptr = NullSockAddr -> IO NullSockAddr
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return NullSockAddr
NullSockAddr
    pokeSocketAddress :: forall a. Ptr a -> NullSockAddr -> IO ()
pokeSocketAddress Ptr a
_ptr NullSockAddr
NullSockAddr = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

sendWithFds :: Socket -> ByteString -> [Fd] -> IO ()
sendWithFds :: Socket -> ByteString -> [Fd] -> IO ()
sendWithFds Socket
s ByteString
msg [Fd]
fds = Int -> IO ()
loop Int
0 where
    loop :: Int -> IO ()
loop Int
acc  = do
        let cmsgs :: [Cmsg]
cmsgs = if Int
acc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then (Fd -> Cmsg
forall a. ControlMessage a => a -> Cmsg
encodeCmsg (Fd -> Cmsg) -> [Fd] -> [Cmsg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Fd]
fds) else []
        Int
n <- ByteString -> (CString -> IO Int) -> IO Int
forall a. ByteString -> (CString -> IO a) -> IO a
unsafeUseAsCString ByteString
msg ((CString -> IO Int) -> IO Int) -> (CString -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \CString
cstr -> do
            let buf :: [(Ptr Word8, Int)]
buf = [(Ptr Any -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr (CString -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr CString
cstr) Int
acc, Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
acc)]
            Socket
-> NullSockAddr
-> [(Ptr Word8, Int)]
-> [Cmsg]
-> MsgFlag
-> IO Int
forall sa.
SocketAddress sa =>
Socket -> sa -> [(Ptr Word8, Int)] -> [Cmsg] -> MsgFlag -> IO Int
Network.Socket.Address.sendBufMsg Socket
s NullSockAddr
NullSockAddr [(Ptr Word8, Int)]
buf [Cmsg]
cmsgs MsgFlag
forall a. Monoid a => a
mempty
        Int -> Socket -> IO ()
waitWhen0 Int
n Socket
s -- copy Network.Socket.ByteString.sendAll
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Int -> IO ()
loop (Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)
    len :: Int
len = ByteString -> Int
Data.ByteString.length ByteString
msg

recvWithFds :: Socket -> Int -> IO (ByteString, [Fd])
recvWithFds :: Socket -> Int -> IO (ByteString, [Fd])
recvWithFds Socket
s = Builder -> [Fd] -> Int -> IO (ByteString, [Fd])
loop Builder
forall a. Monoid a => a
mempty [] where
    loop :: Builder -> [Fd] -> Int -> IO (ByteString, [Fd])
loop Builder
accBuf [Fd]
accFds Int
n = do
        (SockAddr
_sa, ByteString
buf, [Cmsg]
cmsgs, MsgFlag
flag) <- Socket
-> Int
-> Int
-> MsgFlag
-> IO (SockAddr, ByteString, [Cmsg], MsgFlag)
recvMsg Socket
s (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n Int
chunkSize) Int
cmsgsSize MsgFlag
forall a. Monoid a => a
mempty
        let recvLen :: Int
recvLen = ByteString -> Int
Data.ByteString.length ByteString
buf
            accBuf' :: Builder
accBuf' = Builder
accBuf Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Builder.byteString ByteString
buf
            accFds' :: [Fd]
accFds' = [Fd]
accFds [Fd] -> [Fd] -> [Fd]
forall a. Semigroup a => a -> a -> a
<> [Cmsg] -> [Fd]
decodeFdCmsgs [Cmsg]
cmsgs
        case MsgFlag
flag of
            MsgFlag
MSG_CTRUNC -> TransportError -> IO (ByteString, [Fd])
forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError (String
"Unexpected MSG_CTRUNC: more than " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
maxFds String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" file descriptors?"))
            -- no data means unexpected end of connection; maybe the remote end went away.
            MsgFlag
_ | Int
recvLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Int
recvLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n -> do
                (ByteString, [Fd]) -> IO (ByteString, [Fd])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ByteString
Lazy.toStrict (Builder -> ByteString
Builder.toLazyByteString Builder
accBuf'), [Fd]
accFds')
            MsgFlag
_ -> Builder -> [Fd] -> Int -> IO (ByteString, [Fd])
loop Builder
accBuf' [Fd]
accFds' (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
recvLen)
    chunkSize :: Int
chunkSize = Int
4096
    maxFds :: Int
maxFds = Int
16 -- same as DBUS_DEFAULT_MESSAGE_UNIX_FDS in DBUS reference implementation
    cmsgsSize :: Int
cmsgsSize = CInt -> Int
forall a. Storable a => a -> Int
sizeOf (CInt
forall a. HasCallStack => a
undefined :: CInt) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
maxFds

instance TransportOpen SocketTransport where
    transportOpen :: TransportOptions SocketTransport -> Address -> IO SocketTransport
transportOpen TransportOptions SocketTransport
_ Address
a = case Address -> String
addressMethod Address
a of
        String
"unix" -> Address -> IO SocketTransport
openUnix Address
a
        String
"tcp" -> Address -> IO SocketTransport
openTcp Address
a
        String
method -> TransportError -> IO SocketTransport
forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError (String
"Unknown address method: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
method))
            { transportErrorAddress = Just a
            }

instance TransportListen SocketTransport where
    data TransportListener SocketTransport = SocketTransportListener Address UUID Socket
    transportListen :: TransportOptions SocketTransport
-> Address -> IO (TransportListener SocketTransport)
transportListen TransportOptions SocketTransport
opts Address
a = do
        UUID
uuid <- IO UUID
randomUUID
        (Address
a', Socket
sock) <- case Address -> String
addressMethod Address
a of
            String
"unix" -> UUID
-> Address
-> TransportOptions SocketTransport
-> IO (Address, Socket)
listenUnix UUID
uuid Address
a TransportOptions SocketTransport
opts
            String
"tcp" -> UUID
-> Address
-> TransportOptions SocketTransport
-> IO (Address, Socket)
listenTcp UUID
uuid Address
a TransportOptions SocketTransport
opts
            String
method -> TransportError -> IO (Address, Socket)
forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError (String
"Unknown address method: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
method))
                { transportErrorAddress = Just a
                }
        TransportListener SocketTransport
-> IO (TransportListener SocketTransport)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Address -> UUID -> Socket -> TransportListener SocketTransport
SocketTransportListener Address
a' UUID
uuid Socket
sock)
    transportAccept :: TransportListener SocketTransport -> IO SocketTransport
transportAccept (SocketTransportListener Address
a UUID
_ Socket
s) = Maybe Address -> IO SocketTransport -> IO SocketTransport
forall a. Maybe Address -> IO a -> IO a
catchIOException (Address -> Maybe Address
forall a. a -> Maybe a
Just Address
a) (IO SocketTransport -> IO SocketTransport)
-> IO SocketTransport -> IO SocketTransport
forall a b. (a -> b) -> a -> b
$ do
        (Socket
s', SockAddr
_) <- Socket -> IO (Socket, SockAddr)
accept Socket
s
        SocketTransport -> IO SocketTransport
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Address -> Socket -> SocketTransport
SocketTransport Maybe Address
forall a. Maybe a
Nothing Socket
s')
    transportListenerClose :: TransportListener SocketTransport -> IO ()
transportListenerClose (SocketTransportListener Address
a UUID
_ Socket
s) = Maybe Address -> IO () -> IO ()
forall a. Maybe Address -> IO a -> IO a
catchIOException (Address -> Maybe Address
forall a. a -> Maybe a
Just Address
a) (Socket -> IO ()
close Socket
s)
    transportListenerAddress :: TransportListener SocketTransport -> Address
transportListenerAddress (SocketTransportListener Address
a UUID
_ Socket
_) = Address
a
    transportListenerUUID :: TransportListener SocketTransport -> UUID
transportListenerUUID (SocketTransportListener Address
_ UUID
uuid Socket
_) = UUID
uuid

-- | Returns the processID, userID, and groupID of the socket's peer.
--
-- See 'getPeerCredential'.
socketTransportCredentials :: SocketTransport -> IO (Maybe CUInt, Maybe CUInt, Maybe CUInt)
socketTransportCredentials :: SocketTransport -> IO (Maybe CUInt, Maybe CUInt, Maybe CUInt)
socketTransportCredentials (SocketTransport Maybe Address
a Socket
s) = Maybe Address
-> IO (Maybe CUInt, Maybe CUInt, Maybe CUInt)
-> IO (Maybe CUInt, Maybe CUInt, Maybe CUInt)
forall a. Maybe Address -> IO a -> IO a
catchIOException Maybe Address
a (Socket -> IO (Maybe CUInt, Maybe CUInt, Maybe CUInt)
getPeerCredential Socket
s)

openUnix :: Address -> IO SocketTransport
openUnix :: Address -> IO SocketTransport
openUnix Address
transportAddr = IO SocketTransport
go where
    params :: Map String String
params = Address -> Map String String
addressParameters Address
transportAddr
    param :: String -> Maybe String
param String
key = String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
key Map String String
params

    tooMany :: String
tooMany = String
"Only one of 'path' or 'abstract' may be specified for the\
              \ 'unix' transport."
    tooFew :: String
tooFew = String
"One of 'path' or 'abstract' must be specified for the\
             \ 'unix' transport."

    path :: Either String String
path = case (String -> Maybe String
param String
"path", String -> Maybe String
param String
"abstract") of
        (Just String
x, Maybe String
Nothing) -> String -> Either String String
forall a b. b -> Either a b
Right String
x
        (Maybe String
Nothing, Just String
x) -> String -> Either String String
forall a b. b -> Either a b
Right (Char
'\x00' Char -> ShowS
forall a. a -> [a] -> [a]
: String
x)
        (Maybe String
Nothing, Maybe String
Nothing) -> String -> Either String String
forall a b. a -> Either a b
Left String
tooFew
        (Maybe String, Maybe String)
_ -> String -> Either String String
forall a b. a -> Either a b
Left String
tooMany

    go :: IO SocketTransport
go = case Either String String
path of
        Left String
err -> TransportError -> IO SocketTransport
forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError String
err)
            { transportErrorAddress = Just transportAddr
            }
        Right String
p -> Maybe Address -> IO SocketTransport -> IO SocketTransport
forall a. Maybe Address -> IO a -> IO a
catchIOException (Address -> Maybe Address
forall a. a -> Maybe a
Just Address
transportAddr) (IO SocketTransport -> IO SocketTransport)
-> IO SocketTransport -> IO SocketTransport
forall a b. (a -> b) -> a -> b
$ IO Socket
-> (Socket -> IO ())
-> (Socket -> IO SocketTransport)
-> IO SocketTransport
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
            (Family -> SocketType -> CInt -> IO Socket
socket Family
AF_UNIX SocketType
Stream CInt
defaultProtocol)
            Socket -> IO ()
close
            (\Socket
sock -> do
                Socket -> SockAddr -> IO ()
connect Socket
sock (String -> SockAddr
SockAddrUnix String
p)
                SocketTransport -> IO SocketTransport
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Address -> Socket -> SocketTransport
SocketTransport (Address -> Maybe Address
forall a. a -> Maybe a
Just Address
transportAddr) Socket
sock))

tcpHostname :: Maybe String -> Either a Network.Socket.Family -> String
tcpHostname :: forall a. Maybe String -> Either a Family -> String
tcpHostname (Just String
host) Either a Family
_ = String
host
tcpHostname Maybe String
Nothing (Right Family
AF_INET) = String
"127.0.0.1"
tcpHostname Maybe String
Nothing (Right Family
AF_INET6) = String
"::1"
tcpHostname Maybe String
_ Either a Family
_ = String
"localhost"

openTcp :: Address -> IO SocketTransport
openTcp :: Address -> IO SocketTransport
openTcp Address
transportAddr = IO SocketTransport
go where
    params :: Map String String
params = Address -> Map String String
addressParameters Address
transportAddr
    param :: String -> Maybe String
param String
key = String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
key Map String String
params

    hostname :: String
hostname = Maybe String -> Either String Family -> String
forall a. Maybe String -> Either a Family -> String
tcpHostname (String -> Maybe String
param String
"host") Either String Family
getFamily
    unknownFamily :: a -> String
unknownFamily a
x = String
"Unknown socket family for TCP transport: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x
    getFamily :: Either String Family
getFamily = case String -> Maybe String
param String
"family" of
        Just String
"ipv4" -> Family -> Either String Family
forall a b. b -> Either a b
Right Family
AF_INET
        Just String
"ipv6" -> Family -> Either String Family
forall a b. b -> Either a b
Right Family
AF_INET6
        Maybe String
Nothing     -> Family -> Either String Family
forall a b. b -> Either a b
Right Family
AF_UNSPEC
        Just String
x      -> String -> Either String Family
forall a b. a -> Either a b
Left (ShowS
forall a. Show a => a -> String
unknownFamily String
x)
    missingPort :: String
missingPort = String
"TCP transport requires the `port' parameter."
    badPort :: a -> String
badPort a
x = String
"Invalid socket port for TCP transport: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x
    getPort :: Either String PortNumber
getPort = case String -> Maybe String
param String
"port" of
        Maybe String
Nothing -> String -> Either String PortNumber
forall a b. a -> Either a b
Left String
missingPort
        Just String
x -> case String -> Maybe PortNumber
readPortNumber String
x of
            Just PortNumber
port -> PortNumber -> Either String PortNumber
forall a b. b -> Either a b
Right PortNumber
port
            Maybe PortNumber
Nothing -> String -> Either String PortNumber
forall a b. a -> Either a b
Left (ShowS
forall a. Show a => a -> String
badPort String
x)

    getAddresses :: Family -> IO [AddrInfo]
getAddresses Family
family_ = Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just (AddrInfo
defaultHints
        { addrFlags = [AI_ADDRCONFIG]
        , addrFamily = family_
        , addrSocketType = Stream
        })) (String -> Maybe String
forall a. a -> Maybe a
Just String
hostname) Maybe String
forall a. Maybe a
Nothing

    openOneSocket :: [AddrInfo] -> IO Socket
openOneSocket [] = TransportError -> IO Socket
forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError String
"openTcp: no addresses")
        { transportErrorAddress = Just transportAddr
        }
    openOneSocket (AddrInfo
addr:[AddrInfo]
addrs) = do
        Either IOException Socket
tried <- IO Socket -> IO (Either IOException Socket)
forall e a. Exception e => IO a -> IO (Either e a)
Control.Exception.try (IO Socket -> IO (Either IOException Socket))
-> IO Socket -> IO (Either IOException Socket)
forall a b. (a -> b) -> a -> b
$ IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
            (Family -> SocketType -> CInt -> IO Socket
socket (AddrInfo -> Family
addrFamily AddrInfo
addr) (AddrInfo -> SocketType
addrSocketType AddrInfo
addr) (AddrInfo -> CInt
addrProtocol AddrInfo
addr))
            Socket -> IO ()
close
            (\Socket
sock -> do
                Socket -> SockAddr -> IO ()
connect Socket
sock (AddrInfo -> SockAddr
addrAddress AddrInfo
addr)
                Socket -> IO Socket
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock)
        case Either IOException Socket
tried of
            Left IOException
err -> case [AddrInfo]
addrs of
                [] -> TransportError -> IO Socket
forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError (IOException -> String
forall a. Show a => a -> String
show (IOException
err :: IOException)))
                    { transportErrorAddress = Just transportAddr
                    }
                [AddrInfo]
_ -> [AddrInfo] -> IO Socket
openOneSocket [AddrInfo]
addrs
            Right Socket
sock -> Socket -> IO Socket
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock

    go :: IO SocketTransport
go = case Either String PortNumber
getPort of
        Left String
err -> TransportError -> IO SocketTransport
forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError String
err)
            { transportErrorAddress = Just transportAddr
            }
        Right PortNumber
port -> case Either String Family
getFamily of
            Left String
err -> TransportError -> IO SocketTransport
forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError String
err)
                { transportErrorAddress = Just transportAddr
                }
            Right Family
family_ -> Maybe Address -> IO SocketTransport -> IO SocketTransport
forall a. Maybe Address -> IO a -> IO a
catchIOException (Address -> Maybe Address
forall a. a -> Maybe a
Just Address
transportAddr) (IO SocketTransport -> IO SocketTransport)
-> IO SocketTransport -> IO SocketTransport
forall a b. (a -> b) -> a -> b
$ do
                [AddrInfo]
addrs <- Family -> IO [AddrInfo]
getAddresses Family
family_
                Socket
sock <- [AddrInfo] -> IO Socket
openOneSocket ((AddrInfo -> AddrInfo) -> [AddrInfo] -> [AddrInfo]
forall a b. (a -> b) -> [a] -> [b]
map (PortNumber -> AddrInfo -> AddrInfo
setPort PortNumber
port) [AddrInfo]
addrs)
                SocketTransport -> IO SocketTransport
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Address -> Socket -> SocketTransport
SocketTransport (Address -> Maybe Address
forall a. a -> Maybe a
Just Address
transportAddr) Socket
sock)

listenUnix :: UUID -> Address -> TransportOptions SocketTransport -> IO (Address, Socket)
listenUnix :: UUID
-> Address
-> TransportOptions SocketTransport
-> IO (Address, Socket)
listenUnix UUID
uuid Address
origAddr TransportOptions SocketTransport
opts = IO (Either String (Address, String))
getPath IO (Either String (Address, String))
-> (Either String (Address, String) -> IO (Address, Socket))
-> IO (Address, Socket)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either String (Address, String) -> IO (Address, Socket)
go where
    params :: Map String String
params = Address -> Map String String
addressParameters Address
origAddr
    param :: String -> Maybe String
param String
key = String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
key Map String String
params

    tooMany :: String
tooMany = String
"Only one of 'abstract', 'path', or 'tmpdir' may be\
              \ specified for the 'unix' transport."
    tooFew :: String
tooFew = String
"One of 'abstract', 'path', or 'tmpdir' must be specified\
             \ for the 'unix' transport."

    getPath :: IO (Either String (Address, String))
getPath = case (String -> Maybe String
param String
"abstract", String -> Maybe String
param String
"path", String -> Maybe String
param String
"tmpdir") of
        (Just String
path, Maybe String
Nothing, Maybe String
Nothing) -> let
            addr :: Address
addr = String -> [(String, String)] -> Address
address_ String
"unix"
                [ (String
"abstract", String
path)
                , (String
"guid", UUID -> String
formatUUID UUID
uuid)
                ]
            in Either String (Address, String)
-> IO (Either String (Address, String))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Address, String) -> Either String (Address, String)
forall a b. b -> Either a b
Right (Address
addr, Char
'\x00' Char -> ShowS
forall a. a -> [a] -> [a]
: String
path))
        (Maybe String
Nothing, Just String
path, Maybe String
Nothing) -> let
            addr :: Address
addr = String -> [(String, String)] -> Address
address_ String
"unix"
                [ (String
"path", String
path)
                , (String
"guid", UUID -> String
formatUUID UUID
uuid)
                ]
            in Either String (Address, String)
-> IO (Either String (Address, String))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Address, String) -> Either String (Address, String)
forall a b. b -> Either a b
Right (Address
addr, String
path))
        (Maybe String
Nothing, Maybe String
Nothing, Just String
x) -> do
            let fileName :: String
fileName = String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/haskell-dbus-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ UUID -> String
formatUUID UUID
uuid

            -- Abstract paths are supported on Linux, but not on
            -- other Unix-like systems.
            let ([(String, String)]
addrParams, String
path) = if String
System.Info.os String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"linux"
                    then ([(String
"abstract", String
fileName)], Char
'\x00' Char -> ShowS
forall a. a -> [a] -> [a]
: String
fileName)
                    else ([(String
"path", String
fileName)], String
fileName)

            let addr :: Address
addr = String -> [(String, String)] -> Address
address_ String
"unix" ([(String, String)]
addrParams [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String
"guid", UUID -> String
formatUUID UUID
uuid)])
            Either String (Address, String)
-> IO (Either String (Address, String))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Address, String) -> Either String (Address, String)
forall a b. b -> Either a b
Right (Address
addr, String
path))
        (Maybe String
Nothing, Maybe String
Nothing, Maybe String
Nothing) -> Either String (Address, String)
-> IO (Either String (Address, String))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String (Address, String)
forall a b. a -> Either a b
Left String
tooFew)
        (Maybe String, Maybe String, Maybe String)
_ -> Either String (Address, String)
-> IO (Either String (Address, String))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String (Address, String)
forall a b. a -> Either a b
Left String
tooMany)

    go :: Either String (Address, String) -> IO (Address, Socket)
go Either String (Address, String)
path = case Either String (Address, String)
path of
        Left String
err -> TransportError -> IO (Address, Socket)
forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError String
err)
            { transportErrorAddress = Just origAddr
            }
        Right (Address
addr, String
p) -> Maybe Address -> IO (Address, Socket) -> IO (Address, Socket)
forall a. Maybe Address -> IO a -> IO a
catchIOException (Address -> Maybe Address
forall a. a -> Maybe a
Just Address
origAddr) (IO (Address, Socket) -> IO (Address, Socket))
-> IO (Address, Socket) -> IO (Address, Socket)
forall a b. (a -> b) -> a -> b
$ IO Socket
-> (Socket -> IO ())
-> (Socket -> IO (Address, Socket))
-> IO (Address, Socket)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
            (Family -> SocketType -> CInt -> IO Socket
socket Family
AF_UNIX SocketType
Stream CInt
defaultProtocol)
            Socket -> IO ()
close
            (\Socket
sock -> do
                Socket -> SockAddr -> IO ()
bind Socket
sock (String -> SockAddr
SockAddrUnix String
p)
                Socket -> Int -> IO ()
Network.Socket.listen Socket
sock (TransportOptions SocketTransport -> Int
socketTransportOptionBacklog TransportOptions SocketTransport
opts)
                (Address, Socket) -> IO (Address, Socket)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Address
addr, Socket
sock))

listenTcp :: UUID -> Address -> TransportOptions SocketTransport -> IO (Address, Socket)
listenTcp :: UUID
-> Address
-> TransportOptions SocketTransport
-> IO (Address, Socket)
listenTcp UUID
uuid Address
origAddr TransportOptions SocketTransport
opts = IO (Address, Socket)
go where
    params :: Map String String
params = Address -> Map String String
addressParameters Address
origAddr
    param :: String -> Maybe String
param String
key = String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
key Map String String
params

    unknownFamily :: a -> String
unknownFamily a
x = String
"Unknown socket family for TCP transport: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x
    getFamily :: Either String Family
getFamily = case String -> Maybe String
param String
"family" of
        Just String
"ipv4" -> Family -> Either String Family
forall a b. b -> Either a b
Right Family
AF_INET
        Just String
"ipv6" -> Family -> Either String Family
forall a b. b -> Either a b
Right Family
AF_INET6
        Maybe String
Nothing     -> Family -> Either String Family
forall a b. b -> Either a b
Right Family
AF_UNSPEC
        Just String
x      -> String -> Either String Family
forall a b. a -> Either a b
Left (ShowS
forall a. Show a => a -> String
unknownFamily String
x)

    badPort :: a -> String
badPort a
x = String
"Invalid socket port for TCP transport: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x
    getPort :: Either String PortNumber
getPort = case String -> Maybe String
param String
"port" of
        Maybe String
Nothing -> PortNumber -> Either String PortNumber
forall a b. b -> Either a b
Right PortNumber
0
        Just String
x -> case String -> Maybe PortNumber
readPortNumber String
x of
            Just PortNumber
port -> PortNumber -> Either String PortNumber
forall a b. b -> Either a b
Right PortNumber
port
            Maybe PortNumber
Nothing -> String -> Either String PortNumber
forall a b. a -> Either a b
Left (ShowS
forall a. Show a => a -> String
badPort String
x)

    paramBind :: Maybe String
paramBind = case String -> Maybe String
param String
"bind" of
        Just String
"*" -> Maybe String
forall a. Maybe a
Nothing
        Just String
x -> String -> Maybe String
forall a. a -> Maybe a
Just String
x
        Maybe String
Nothing -> String -> Maybe String
forall a. a -> Maybe a
Just (Maybe String -> Either String Family -> String
forall a. Maybe String -> Either a Family -> String
tcpHostname (String -> Maybe String
param String
"host") Either String Family
getFamily)

    getAddresses :: Family -> IO [AddrInfo]
getAddresses Family
family_ = Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just (AddrInfo
defaultHints
        { addrFlags = [AI_ADDRCONFIG, AI_PASSIVE]
        , addrFamily = family_
        , addrSocketType = Stream
        })) Maybe String
paramBind Maybe String
forall a. Maybe a
Nothing

    bindAddrs :: Socket -> [AddrInfo] -> IO ()
bindAddrs Socket
_ [] = TransportError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError String
"listenTcp: no addresses")
        { transportErrorAddress = Just origAddr
        }
    bindAddrs Socket
sock (AddrInfo
addr:[AddrInfo]
addrs) = do
        Either IOException ()
tried <- IO () -> IO (Either IOException ())
forall e a. Exception e => IO a -> IO (Either e a)
Control.Exception.try (Socket -> SockAddr -> IO ()
bind Socket
sock (AddrInfo -> SockAddr
addrAddress AddrInfo
addr))
        case Either IOException ()
tried of
            Left IOException
err -> case [AddrInfo]
addrs of
                [] -> TransportError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError (IOException -> String
forall a. Show a => a -> String
show (IOException
err :: IOException)))
                    { transportErrorAddress = Just origAddr
                    }
                [AddrInfo]
_ -> Socket -> [AddrInfo] -> IO ()
bindAddrs Socket
sock [AddrInfo]
addrs
            Right ()
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    sockAddr :: PortNumber -> Address
sockAddr PortNumber
port = String -> [(String, String)] -> Address
address_ String
"tcp" [(String, String)]
p where
        p :: [(String, String)]
p = [(String, String)]
baseParams [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String, String)]
hostParam [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String, String)]
familyParam
        baseParams :: [(String, String)]
baseParams =
            [ (String
"port", PortNumber -> String
forall a. Show a => a -> String
show PortNumber
port)
            , (String
"guid", UUID -> String
formatUUID UUID
uuid)
            ]
        hostParam :: [(String, String)]
hostParam = case String -> Maybe String
param String
"host" of
            Just String
x -> [(String
"host", String
x)]
            Maybe String
Nothing -> []
        familyParam :: [(String, String)]
familyParam = case String -> Maybe String
param String
"family" of
            Just String
x -> [(String
"family", String
x)]
            Maybe String
Nothing -> []

    go :: IO (Address, Socket)
go = case Either String PortNumber
getPort of
        Left String
err -> TransportError -> IO (Address, Socket)
forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError String
err)
            { transportErrorAddress = Just origAddr
            }
        Right PortNumber
port -> case Either String Family
getFamily of
            Left String
err -> TransportError -> IO (Address, Socket)
forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError String
err)
                { transportErrorAddress = Just origAddr
                }
            Right Family
family_ -> Maybe Address -> IO (Address, Socket) -> IO (Address, Socket)
forall a. Maybe Address -> IO a -> IO a
catchIOException (Address -> Maybe Address
forall a. a -> Maybe a
Just Address
origAddr) (IO (Address, Socket) -> IO (Address, Socket))
-> IO (Address, Socket) -> IO (Address, Socket)
forall a b. (a -> b) -> a -> b
$ do
                [AddrInfo]
sockAddrs <- Family -> IO [AddrInfo]
getAddresses Family
family_
                IO Socket
-> (Socket -> IO ())
-> (Socket -> IO (Address, Socket))
-> IO (Address, Socket)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
                    (Family -> SocketType -> CInt -> IO Socket
socket Family
family_ SocketType
Stream CInt
defaultProtocol)
                    Socket -> IO ()
close
                    (\Socket
sock -> do
                        Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
sock SocketOption
ReuseAddr Int
1
                        Socket -> [AddrInfo] -> IO ()
bindAddrs Socket
sock ((AddrInfo -> AddrInfo) -> [AddrInfo] -> [AddrInfo]
forall a b. (a -> b) -> [a] -> [b]
map (PortNumber -> AddrInfo -> AddrInfo
setPort PortNumber
port) [AddrInfo]
sockAddrs)

                        Socket -> Int -> IO ()
Network.Socket.listen Socket
sock (TransportOptions SocketTransport -> Int
socketTransportOptionBacklog TransportOptions SocketTransport
opts)
                        PortNumber
sockPort <- Socket -> IO PortNumber
socketPort Socket
sock
                        (Address, Socket) -> IO (Address, Socket)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PortNumber -> Address
sockAddr PortNumber
sockPort, Socket
sock))

catchIOException :: Maybe Address -> IO a -> IO a
catchIOException :: forall a. Maybe Address -> IO a -> IO a
catchIOException Maybe Address
addr IO a
io = do
    Either IOException a
tried <- IO a -> IO (Either IOException a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
io
    case Either IOException a
tried of
        Right a
a -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
        Left IOException
err -> TransportError -> IO a
forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError (IOException -> String
forall a. Show a => a -> String
show (IOException
err :: IOException)))
            { transportErrorAddress = addr
            }

address_ :: String -> [(String, String)] -> Address
address_ :: String -> [(String, String)] -> Address
address_ String
method [(String, String)]
params = Address
addr where
    Just Address
addr = String -> Map String String -> Maybe Address
address String
method ([(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String, String)]
params)

setPort :: PortNumber -> AddrInfo -> AddrInfo
setPort :: PortNumber -> AddrInfo -> AddrInfo
setPort PortNumber
port AddrInfo
info = case AddrInfo -> SockAddr
addrAddress AddrInfo
info of
    (SockAddrInet  PortNumber
_ HostAddress
x) -> AddrInfo
info { addrAddress = SockAddrInet port x }
    (SockAddrInet6 PortNumber
_ HostAddress
x HostAddress6
y HostAddress
z) -> AddrInfo
info { addrAddress = SockAddrInet6 port x y z }
    SockAddr
_ -> AddrInfo
info

readPortNumber :: String -> Maybe PortNumber
readPortNumber :: String -> Maybe PortNumber
readPortNumber String
s = do
    case (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9') String
s of
        [] -> () -> Maybe ()
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        String
_ -> Maybe ()
forall a. Maybe a
Nothing
    let word :: Integer
word = String -> Integer
forall a. Read a => String -> a
read String
s :: Integer
    if Integer
word Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 Bool -> Bool -> Bool
&& Integer
word Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
65535
        then PortNumber -> Maybe PortNumber
forall a. a -> Maybe a
Just (Integer -> PortNumber
forall a. Num a => Integer -> a
fromInteger Integer
word)
        else Maybe PortNumber
forall a. Maybe a
Nothing

-- | Copied from Network.Socket.ByteString.IO
waitWhen0 :: Int -> Socket -> IO ()
waitWhen0 :: Int -> Socket -> IO ()
waitWhen0 Int
0 Socket
s = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
rtsSupportsBoundThreads (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Socket -> (CInt -> IO ()) -> IO ()
forall r. Socket -> (CInt -> IO r) -> IO r
withFdSocket Socket
s ((CInt -> IO ()) -> IO ()) -> (CInt -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CInt
fd -> Fd -> IO ()
threadWaitWrite (Fd -> IO ()) -> Fd -> IO ()
forall a b. (a -> b) -> a -> b
$ CInt -> Fd
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
fd
waitWhen0 Int
_ Socket
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

decodeFdCmsgs :: [Cmsg] -> [Fd]
decodeFdCmsgs :: [Cmsg] -> [Fd]
decodeFdCmsgs [Cmsg]
cmsgs =
    (Cmsg -> [Fd]) -> [Cmsg] -> [Fd]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ([Fd] -> Maybe [Fd] -> [Fd]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Fd] -> [Fd]) -> (Cmsg -> Maybe [Fd]) -> Cmsg -> [Fd]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cmsg -> Maybe [Fd]
decodeFdCmsg) [Cmsg]
cmsgs

-- | Special decode function to handle > 1 Fd. Should be able to replace with a function
-- from the network package in future (https://github.com/haskell/network/issues/566)
decodeFdCmsg :: Cmsg -> Maybe [Fd]
decodeFdCmsg :: Cmsg -> Maybe [Fd]
decodeFdCmsg (Cmsg CmsgId
cmsid (PS ForeignPtr Word8
fptr Int
off Int
len))
  | CmsgId
cmsid CmsgId -> CmsgId -> Bool
forall a. Eq a => a -> a -> Bool
/= CmsgId
CmsgIdFd = Maybe [Fd]
forall a. Maybe a
Nothing
  | Bool
otherwise =
    IO (Maybe [Fd]) -> Maybe [Fd]
forall a. IO a -> a
unsafeDupablePerformIO (IO (Maybe [Fd]) -> Maybe [Fd]) -> IO (Maybe [Fd]) -> Maybe [Fd]
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8
-> (Ptr Word8 -> IO (Maybe [Fd])) -> IO (Maybe [Fd])
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fptr ((Ptr Word8 -> IO (Maybe [Fd])) -> IO (Maybe [Fd]))
-> (Ptr Word8 -> IO (Maybe [Fd])) -> IO (Maybe [Fd])
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p0 -> do
      let p :: Ptr Fd
p = Ptr Any -> Ptr Fd
forall a b. Ptr a -> Ptr b
castPtr (Ptr Word8
p0 Ptr Word8 -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off)
          numFds :: Int
numFds = Int
len Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Fd -> Int
forall a. Storable a => a -> Int
sizeOf (Fd
forall a. HasCallStack => a
undefined :: Fd)
      [Fd] -> Maybe [Fd]
forall a. a -> Maybe a
Just ([Fd] -> Maybe [Fd]) -> IO [Fd] -> IO (Maybe [Fd])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Ptr Fd -> IO [Fd]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
numFds Ptr Fd
p