{-# 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TransportError -> TransportError -> Bool
$c/= :: TransportError -> TransportError -> Bool
== :: TransportError -> TransportError -> Bool
$c== :: TransportError -> TransportError -> Bool
Eq, Int -> TransportError -> ShowS
[TransportError] -> ShowS
TransportError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TransportError] -> ShowS
$cshowList :: [TransportError] -> ShowS
show :: TransportError -> String
$cshow :: TransportError -> String
showsPrec :: Int -> TransportError -> ShowS
$cshowsPrec :: Int -> TransportError -> ShowS
Show, Typeable)
instance Exception TransportError
transportError :: String -> TransportError
transportError :: String -> TransportError
transportError String
msg = String -> Maybe Address -> TransportError
TransportError String
msg 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 = 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 <- forall t. Transport t => t -> Int -> IO ByteString
transportGet t
t Int
n
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 = 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 = 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 = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = 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) = 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 = forall (m :: * -> *) a. Monad m => a -> m a
return NullSockAddr
NullSockAddr
pokeSocketAddress :: forall a. Ptr a -> NullSockAddr -> IO ()
pokeSocketAddress Ptr a
_ptr NullSockAddr
NullSockAddr = 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 forall a. Eq a => a -> a -> Bool
== Int
0 then (forall a. ControlMessage a => a -> Cmsg
encodeCmsg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Fd]
fds) else []
Int
n <- forall a. ByteString -> (CString -> IO a) -> IO a
unsafeUseAsCString ByteString
msg forall a b. (a -> b) -> a -> b
$ \CString
cstr -> do
let buf :: [(Ptr Word8, Int)]
buf = [(forall a b. Ptr a -> Int -> Ptr b
plusPtr (forall a b. Ptr a -> Ptr b
castPtr CString
cstr) Int
acc, Int
len forall a. Num a => a -> a -> a
- Int
acc)]
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 forall a. Monoid a => a
mempty
Int -> Socket -> IO ()
waitWhen0 Int
n Socket
s
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
acc forall a. Num a => a -> a -> a
+ Int
n forall a. Ord a => a -> a -> Bool
< Int
len) forall a b. (a -> b) -> a -> b
$ do
Int -> IO ()
loop (Int
acc 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 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 (forall a. Ord a => a -> a -> a
min Int
n Int
chunkSize) Int
cmsgsSize forall a. Monoid a => a
mempty
let recvLen :: Int
recvLen = ByteString -> Int
Data.ByteString.length ByteString
buf
accBuf' :: Builder
accBuf' = Builder
accBuf forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Builder.byteString ByteString
buf
accFds' :: [Fd]
accFds' = [Fd]
accFds forall a. Semigroup a => a -> a -> a
<> [Cmsg] -> [Fd]
decodeFdCmsgs [Cmsg]
cmsgs
case MsgFlag
flag of
MsgFlag
MSG_CTRUNC -> forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError (String
"Unexpected MSG_CTRUNC: more than " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
maxFds forall a. Semigroup a => a -> a -> a
<> String
" file descriptors?"))
MsgFlag
_ | Int
recvLen forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Int
recvLen forall a. Eq a => a -> a -> Bool
== Int
n -> do
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 forall a. Num a => a -> a -> a
- Int
recvLen)
chunkSize :: Int
chunkSize = Int
4096
maxFds :: Int
maxFds = Int
16
cmsgsSize :: Int
cmsgsSize = forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: CInt) 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 -> forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError (String
"Unknown address method: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
method))
{ transportErrorAddress :: Maybe Address
transportErrorAddress = forall a. a -> Maybe a
Just Address
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 -> forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError (String
"Unknown address method: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
method))
{ transportErrorAddress :: Maybe Address
transportErrorAddress = forall a. a -> Maybe a
Just Address
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) = forall a. Maybe Address -> IO a -> IO a
catchIOException (forall a. a -> Maybe a
Just Address
a) forall a b. (a -> b) -> a -> b
$ do
(Socket
s', SockAddr
_) <- Socket -> IO (Socket, SockAddr)
accept Socket
s
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Address -> Socket -> SocketTransport
SocketTransport forall a. Maybe a
Nothing Socket
s')
transportListenerClose :: TransportListener SocketTransport -> IO ()
transportListenerClose (SocketTransportListener Address
a UUID
_ Socket
s) = forall a. Maybe Address -> IO a -> IO a
catchIOException (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) = 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 = 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) -> forall a b. b -> Either a b
Right String
x
(Maybe String
Nothing, Just String
x) -> forall a b. b -> Either a b
Right (Char
'\x00' forall a. a -> [a] -> [a]
: String
x)
(Maybe String
Nothing, Maybe String
Nothing) -> forall a b. a -> Either a b
Left String
tooFew
(Maybe String, Maybe String)
_ -> forall a b. a -> Either a b
Left String
tooMany
go :: IO SocketTransport
go = case Either String String
path of
Left String
err -> forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError String
err)
{ transportErrorAddress :: Maybe Address
transportErrorAddress = forall a. a -> Maybe a
Just Address
transportAddr
}
Right String
p -> forall a. Maybe Address -> IO a -> IO a
catchIOException (forall a. a -> Maybe a
Just Address
transportAddr) forall a b. (a -> b) -> a -> b
$ 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)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Address -> Socket -> SocketTransport
SocketTransport (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 = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
key Map String String
params
hostname :: String
hostname = 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: " forall a. [a] -> [a] -> [a]
++ 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" -> forall a b. b -> Either a b
Right Family
AF_INET
Just String
"ipv6" -> forall a b. b -> Either a b
Right Family
AF_INET6
Maybe String
Nothing -> forall a b. b -> Either a b
Right Family
AF_UNSPEC
Just String
x -> forall a b. a -> Either a b
Left (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: " forall a. [a] -> [a] -> [a]
++ 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 -> forall a b. a -> Either a b
Left String
missingPort
Just String
x -> case String -> Maybe PortNumber
readPortNumber String
x of
Just PortNumber
port -> forall a b. b -> Either a b
Right PortNumber
port
Maybe PortNumber
Nothing -> forall a b. a -> Either a b
Left (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 (forall a. a -> Maybe a
Just (AddrInfo
defaultHints
{ addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_ADDRCONFIG]
, addrFamily :: Family
addrFamily = Family
family_
, addrSocketType :: SocketType
addrSocketType = SocketType
Stream
})) (forall a. a -> Maybe a
Just String
hostname) forall a. Maybe a
Nothing
openOneSocket :: [AddrInfo] -> IO Socket
openOneSocket [] = forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError String
"openTcp: no addresses")
{ transportErrorAddress :: Maybe Address
transportErrorAddress = forall a. a -> Maybe a
Just Address
transportAddr
}
openOneSocket (AddrInfo
addr:[AddrInfo]
addrs) = do
Either IOException Socket
tried <- forall e a. Exception e => IO a -> IO (Either e a)
Control.Exception.try forall a b. (a -> b) -> a -> b
$ 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)
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock)
case Either IOException Socket
tried of
Left IOException
err -> case [AddrInfo]
addrs of
[] -> forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError (forall a. Show a => a -> String
show (IOException
err :: IOException)))
{ transportErrorAddress :: Maybe Address
transportErrorAddress = forall a. a -> Maybe a
Just Address
transportAddr
}
[AddrInfo]
_ -> [AddrInfo] -> IO Socket
openOneSocket [AddrInfo]
addrs
Right Socket
sock -> forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
go :: IO SocketTransport
go = case Either String PortNumber
getPort of
Left String
err -> forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError String
err)
{ transportErrorAddress :: Maybe Address
transportErrorAddress = forall a. a -> Maybe a
Just Address
transportAddr
}
Right PortNumber
port -> case Either String Family
getFamily of
Left String
err -> forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError String
err)
{ transportErrorAddress :: Maybe Address
transportErrorAddress = forall a. a -> Maybe a
Just Address
transportAddr
}
Right Family
family_ -> forall a. Maybe Address -> IO a -> IO a
catchIOException (forall a. a -> Maybe a
Just Address
transportAddr) forall a b. (a -> b) -> a -> b
$ do
[AddrInfo]
addrs <- Family -> IO [AddrInfo]
getAddresses Family
family_
Socket
sock <- [AddrInfo] -> IO Socket
openOneSocket (forall a b. (a -> b) -> [a] -> [b]
map (PortNumber -> AddrInfo -> AddrInfo
setPort PortNumber
port) [AddrInfo]
addrs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Address -> Socket -> SocketTransport
SocketTransport (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 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 = 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 forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (Address
addr, Char
'\x00' 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 forall (m :: * -> *) a. Monad m => a -> m a
return (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 forall a. [a] -> [a] -> [a]
++ String
"/haskell-dbus-" forall a. [a] -> [a] -> [a]
++ UUID -> String
formatUUID UUID
uuid
let ([(String, String)]
addrParams, String
path) = if String
System.Info.os forall a. Eq a => a -> a -> Bool
== String
"linux"
then ([(String
"abstract", String
fileName)], Char
'\x00' 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 forall a. [a] -> [a] -> [a]
++ [(String
"guid", UUID -> String
formatUUID UUID
uuid)])
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (Address
addr, String
path))
(Maybe String
Nothing, Maybe String
Nothing, Maybe String
Nothing) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left String
tooFew)
(Maybe String, Maybe String, Maybe String)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (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 -> forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError String
err)
{ transportErrorAddress :: Maybe Address
transportErrorAddress = forall a. a -> Maybe a
Just Address
origAddr
}
Right (Address
addr, String
p) -> forall a. Maybe Address -> IO a -> IO a
catchIOException (forall a. a -> Maybe a
Just Address
origAddr) forall a b. (a -> b) -> a -> b
$ 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)
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 = 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: " forall a. [a] -> [a] -> [a]
++ 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" -> forall a b. b -> Either a b
Right Family
AF_INET
Just String
"ipv6" -> forall a b. b -> Either a b
Right Family
AF_INET6
Maybe String
Nothing -> forall a b. b -> Either a b
Right Family
AF_UNSPEC
Just String
x -> forall a b. a -> Either a b
Left (forall a. Show a => a -> String
unknownFamily String
x)
badPort :: a -> String
badPort a
x = String
"Invalid socket port for TCP transport: " forall a. [a] -> [a] -> [a]
++ 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 -> forall a b. b -> Either a b
Right PortNumber
0
Just String
x -> case String -> Maybe PortNumber
readPortNumber String
x of
Just PortNumber
port -> forall a b. b -> Either a b
Right PortNumber
port
Maybe PortNumber
Nothing -> forall a b. a -> Either a b
Left (forall a. Show a => a -> String
badPort String
x)
paramBind :: Maybe String
paramBind = case String -> Maybe String
param String
"bind" of
Just String
"*" -> forall a. Maybe a
Nothing
Just String
x -> forall a. a -> Maybe a
Just String
x
Maybe String
Nothing -> forall a. a -> Maybe a
Just (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 (forall a. a -> Maybe a
Just (AddrInfo
defaultHints
{ addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_ADDRCONFIG, AddrInfoFlag
AI_PASSIVE]
, addrFamily :: Family
addrFamily = Family
family_
, addrSocketType :: SocketType
addrSocketType = SocketType
Stream
})) Maybe String
paramBind forall a. Maybe a
Nothing
bindAddrs :: Socket -> [AddrInfo] -> IO ()
bindAddrs Socket
_ [] = forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError String
"listenTcp: no addresses")
{ transportErrorAddress :: Maybe Address
transportErrorAddress = forall a. a -> Maybe a
Just Address
origAddr
}
bindAddrs Socket
sock (AddrInfo
addr:[AddrInfo]
addrs) = do
Either IOException ()
tried <- 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
[] -> forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError (forall a. Show a => a -> String
show (IOException
err :: IOException)))
{ transportErrorAddress :: Maybe Address
transportErrorAddress = forall a. a -> Maybe a
Just Address
origAddr
}
[AddrInfo]
_ -> Socket -> [AddrInfo] -> IO ()
bindAddrs Socket
sock [AddrInfo]
addrs
Right ()
_ -> 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 forall a. [a] -> [a] -> [a]
++ [(String, String)]
hostParam forall a. [a] -> [a] -> [a]
++ [(String, String)]
familyParam
baseParams :: [(String, String)]
baseParams =
[ (String
"port", 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 -> forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError String
err)
{ transportErrorAddress :: Maybe Address
transportErrorAddress = forall a. a -> Maybe a
Just Address
origAddr
}
Right PortNumber
port -> case Either String Family
getFamily of
Left String
err -> forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError String
err)
{ transportErrorAddress :: Maybe Address
transportErrorAddress = forall a. a -> Maybe a
Just Address
origAddr
}
Right Family
family_ -> forall a. Maybe Address -> IO a -> IO a
catchIOException (forall a. a -> Maybe a
Just Address
origAddr) forall a b. (a -> b) -> a -> b
$ do
[AddrInfo]
sockAddrs <- Family -> IO [AddrInfo]
getAddresses Family
family_
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 (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
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 <- forall e a. Exception e => IO a -> IO (Either e a)
try IO a
io
case Either IOException a
tried of
Right a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
Left IOException
err -> forall e a. Exception e => e -> IO a
throwIO (String -> TransportError
transportError (forall a. Show a => a -> String
show (IOException
err :: IOException)))
{ transportErrorAddress :: Maybe Address
transportErrorAddress = Maybe Address
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 (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 :: SockAddr
addrAddress = PortNumber -> HostAddress -> SockAddr
SockAddrInet PortNumber
port HostAddress
x }
(SockAddrInet6 PortNumber
_ HostAddress
x HostAddress6
y HostAddress
z) -> AddrInfo
info { addrAddress :: SockAddr
addrAddress = PortNumber
-> HostAddress -> HostAddress6 -> HostAddress -> SockAddr
SockAddrInet6 PortNumber
port HostAddress
x HostAddress6
y HostAddress
z }
SockAddr
_ -> AddrInfo
info
readPortNumber :: String -> Maybe PortNumber
readPortNumber :: String -> Maybe PortNumber
readPortNumber String
s = do
case forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\Char
c -> Char
c forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'9') String
s of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
String
_ -> forall a. Maybe a
Nothing
let word :: Integer
word = forall a. Read a => String -> a
read String
s :: Integer
if Integer
word forall a. Ord a => a -> a -> Bool
> Integer
0 Bool -> Bool -> Bool
&& Integer
word forall a. Ord a => a -> a -> Bool
<= Integer
65535
then forall a. a -> Maybe a
Just (forall a. Num a => Integer -> a
fromInteger Integer
word)
else forall a. Maybe a
Nothing
waitWhen0 :: Int -> Socket -> IO ()
waitWhen0 :: Int -> Socket -> IO ()
waitWhen0 Int
0 Socket
s = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
rtsSupportsBoundThreads forall a b. (a -> b) -> a -> b
$
forall r. Socket -> (CInt -> IO r) -> IO r
withFdSocket Socket
s forall a b. (a -> b) -> a -> b
$ \CInt
fd -> Fd -> IO ()
threadWaitWrite forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
fd
waitWhen0 Int
_ Socket
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
decodeFdCmsgs :: [Cmsg] -> [Fd]
decodeFdCmsgs :: [Cmsg] -> [Fd]
decodeFdCmsgs [Cmsg]
cmsgs =
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. a -> Maybe a -> a
fromMaybe [] 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 forall a. Eq a => a -> a -> Bool
/= CmsgId
CmsgIdFd = forall a. Maybe a
Nothing
| Bool
otherwise =
forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$ forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fptr forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p0 -> do
let p :: Ptr Fd
p = forall a b. Ptr a -> Ptr b
castPtr (Ptr Word8
p0 forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off)
numFds :: Int
numFds = Int
len forall a. Integral a => a -> a -> a
`div` forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: Fd)
forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
numFds Ptr Fd
p