{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
module DBus.Transport
(
Transport(..)
, TransportOpen(..)
, TransportListen(..)
, TransportError
, transportError
, transportErrorMessage
, transportErrorAddress
, 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
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
class Transport t where
data TransportOptions t :: Data.Kind.Type
transportDefaultOptions :: TransportOptions t
transportPut :: t -> ByteString -> IO ()
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
transportGet :: t -> Int -> IO ByteString
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, [])
transportClose :: t -> IO ()
class Transport t => TransportOpen t where
transportOpen :: TransportOptions t -> Address -> IO t
class Transport t => TransportListen t where
data TransportListener t :: Data.Kind.Type
transportListen :: TransportOptions t -> Address -> IO (TransportListener t)
transportAccept :: TransportListener t -> IO t
transportListenerClose :: TransportListener t -> IO ()
transportListenerAddress :: TransportListener t -> Address
transportListenerUUID :: TransportListener t -> UUID
data SocketTransport = SocketTransport (Maybe Address) Socket
instance Transport SocketTransport where
data TransportOptions SocketTransport = SocketTransportOptions
{
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)
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
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?"))
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
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
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
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
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
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