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

-- | 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 = 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 = 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) = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Builder -> Int -> IO ByteString
loop 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 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 = 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 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> ByteString
Builder.toLazyByteString Builder
acc)

                Int
len -> do
                    let builder :: Builder
builder = forall a. Monoid a => a -> a -> a
mappend Builder
acc (ByteString -> Builder
Builder.byteString ByteString
chunk)
                    if Int
len forall a. Eq a => a -> a -> Bool
== Int
n
                        then 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 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 -> 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

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

            -- Abstract paths are supported on Linux, but not on
            -- other Unix-like systems.
            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 -> 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)
                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 -> 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 (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