{-# LANGUAGE DeriveDataTypeable #-}
{-# 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.Exception
import qualified Data.ByteString
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.Map as Map
import           Data.Monoid
import           Data.Typeable (Typeable)
import           Foreign.C (CUInt)
import           Network.Socket
import           Network.Socket.ByteString (sendAll, recv)
import qualified System.Info
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
/= :: TransportError -> TransportError -> Bool
$c/= :: TransportError -> TransportError -> Bool
== :: TransportError -> TransportError -> Bool
$c== :: 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
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 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 :: *

    -- | 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 ()

    -- | 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

    -- | 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 :: *

    -- | 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 Maybe Address
addr Socket
s) ByteString
bytes = Maybe Address -> IO () -> IO ()
forall a. Maybe Address -> IO a -> IO a
catchIOException Maybe Address
addr (Socket -> ByteString -> IO ()
sendAll Socket
s ByteString
bytes)
    transportGet :: SocketTransport -> Int -> IO ByteString
transportGet (SocketTransport Maybe Address
addr Socket
s) Int
n = Maybe Address -> IO ByteString -> IO ByteString
forall a. Maybe Address -> IO a -> IO a
catchIOException Maybe Address
addr (Socket -> Int -> IO ByteString
recvLoop 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)

recvLoop :: Socket -> Int -> IO ByteString
recvLoop :: Socket -> Int -> IO ByteString
recvLoop Socket
s = \Int
n -> ByteString -> ByteString
Lazy.toStrict (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Builder -> Int -> IO ByteString
loop Builder
forall a. Monoid a => a
mempty Int
n where
    chunkSize :: Int
chunkSize = Int
4096
    loop :: Builder -> Int -> IO ByteString
loop Builder
acc Int
n = if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
chunkSize
        then do
            ByteString
chunk <- Socket -> Int -> IO ByteString
recv Socket
s Int
chunkSize
            let builder :: Builder
builder = Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
mappend Builder
acc (ByteString -> Builder
Builder.byteString ByteString
chunk)
            Builder -> Int -> IO ByteString
loop Builder
builder (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
Data.ByteString.length ByteString
chunk)
        else do
            ByteString
chunk <- Socket -> Int -> IO ByteString
recv Socket
s Int
n
            case ByteString -> Int
Data.ByteString.length ByteString
chunk of
                -- Unexpected end of connection; maybe the remote end went away.
                -- Return what we've got so far.
                Int
0 -> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> ByteString
Builder.toLazyByteString Builder
acc)

                Int
len -> do
                    let builder :: Builder
builder = Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
mappend Builder
acc (ByteString -> Builder
Builder.byteString ByteString
chunk)
                    if Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n
                        then ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> ByteString
Builder.toLazyByteString Builder
builder)
                        else Builder -> Int -> IO ByteString
loop Builder
builder (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
Data.ByteString.length ByteString
chunk)

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 :: Maybe Address
transportErrorAddress = Address -> Maybe Address
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 -> 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 :: Maybe Address
transportErrorAddress = Address -> Maybe Address
forall a. a -> Maybe a
Just Address
a
                }
        TransportListener SocketTransport
-> IO (TransportListener SocketTransport)
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 a _ 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 (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 a _ 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 a _ _) = Address
a
    transportListenerUUID :: TransportListener SocketTransport -> UUID
transportListenerUUID (SocketTransportListener _ uuid _) = 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 :: Maybe Address
transportErrorAddress = Address -> Maybe Address
forall a. a -> Maybe a
Just Address
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 -> ProtocolNumber -> IO Socket
socket Family
AF_UNIX SocketType
Stream ProtocolNumber
defaultProtocol)
            Socket -> IO ()
close
            (\Socket
sock -> do
                Socket -> SockAddr -> IO ()
connect Socket
sock (String -> SockAddr
SockAddrUnix String
p)
                SocketTransport -> IO SocketTransport
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 :: 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 :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_ADDRCONFIG]
        , addrFamily :: Family
addrFamily = Family
family_
        , addrSocketType :: SocketType
addrSocketType = SocketType
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 :: Maybe Address
transportErrorAddress = Address -> Maybe Address
forall a. a -> Maybe a
Just Address
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 -> ProtocolNumber -> IO Socket
socket (AddrInfo -> Family
addrFamily AddrInfo
addr) (AddrInfo -> SocketType
addrSocketType AddrInfo
addr) (AddrInfo -> ProtocolNumber
addrProtocol AddrInfo
addr))
            Socket -> IO ()
close
            (\Socket
sock -> do
                Socket -> SockAddr -> IO ()
connect Socket
sock (AddrInfo -> SockAddr
addrAddress AddrInfo
addr)
                Socket -> IO Socket
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 :: Maybe Address
transportErrorAddress = Address -> Maybe Address
forall a. a -> Maybe a
Just Address
transportAddr
                    }
                [AddrInfo]
_ -> [AddrInfo] -> IO Socket
openOneSocket [AddrInfo]
addrs
            Right Socket
sock -> Socket -> IO Socket
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 :: Maybe Address
transportErrorAddress = Address -> Maybe Address
forall a. a -> Maybe a
Just Address
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 :: Maybe Address
transportErrorAddress = Address -> Maybe Address
forall a. a -> Maybe a
Just Address
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 (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 (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 (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 (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 (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 (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 (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 :: Maybe Address
transportErrorAddress = Address -> Maybe Address
forall a. a -> Maybe a
Just Address
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 -> ProtocolNumber -> IO Socket
socket Family
AF_UNIX SocketType
Stream ProtocolNumber
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 (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 :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_ADDRCONFIG, AddrInfoFlag
AI_PASSIVE]
        , addrFamily :: Family
addrFamily = Family
family_
        , addrSocketType :: SocketType
addrSocketType = SocketType
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 :: Maybe Address
transportErrorAddress = Address -> Maybe Address
forall a. a -> Maybe a
Just Address
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 :: Maybe Address
transportErrorAddress = Address -> Maybe Address
forall a. a -> Maybe a
Just Address
origAddr
                    }
                [AddrInfo]
_ -> Socket -> [AddrInfo] -> IO ()
bindAddrs Socket
sock [AddrInfo]
addrs
            Right ()
_ -> () -> IO ()
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 :: Maybe Address
transportErrorAddress = Address -> Maybe Address
forall a. a -> Maybe a
Just Address
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 :: Maybe Address
transportErrorAddress = Address -> Maybe Address
forall a. a -> Maybe a
Just Address
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 -> ProtocolNumber -> IO Socket
socket Family
family_ SocketType
Stream ProtocolNumber
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 (m :: * -> *) a. Monad m => a -> m a
return (PortNumber -> Address
sockAddr PortNumber
sockPort, Socket
sock))

catchIOException :: Maybe Address -> IO a -> IO a
catchIOException :: 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 (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 :: 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 ([(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 :: 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 (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 (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