module System.Socket.Internal.AddressInfo (
AddressInfo (..)
, GetAddressInfo (..)
, GetNameInfo (..)
, AddressInfoException (..)
, eaiAgain
, eaiBadFlags
, eaiFail
, eaiFamily
, eaiMemory
, eaiNoName
, eaiSocketType
, eaiService
, eaiSystem
, AddressInfoFlags (..)
, aiAddressConfig
, aiAll
, aiCanonicalName
, aiNumericHost
, aiNumericService
, aiPassive
, aiV4Mapped
, NameInfoFlags (..)
, niNameRequired
, niDatagram
, niNoFullyQualifiedDomainName
, niNumericHost
, niNumericService
) where
import Control.Exception
import Control.Monad
import Data.Bits
import Data.Monoid
import Data.Typeable
import qualified Data.ByteString as BS
import Foreign.Ptr
import Foreign.Storable
import Foreign.C.Types
import Foreign.C.String
import Foreign.Marshal.Alloc
import System.IO.Unsafe
import System.Socket.Family
import System.Socket.Family.Inet
import System.Socket.Family.Inet6
import System.Socket.Type
import System.Socket.Protocol
import System.Socket.Internal.Platform
data AddressInfo f t p
= AddressInfo
{ addressInfoFlags :: AddressInfoFlags
, socketAddress :: SocketAddress f
, canonicalName :: Maybe BS.ByteString
}
deriving instance (Eq (SocketAddress f)) => Eq (AddressInfo f t p)
deriving instance (Show (SocketAddress f)) => Show (AddressInfo f t p)
newtype AddressInfoException
= AddressInfoException CInt
deriving (Eq, Typeable)
instance Show AddressInfoException where
show e = "AddressInfoException \"" ++ gaiStrerror e ++ "\""
instance Exception AddressInfoException
gaiStrerror :: AddressInfoException -> String
gaiStrerror (AddressInfoException e) =
unsafePerformIO $ do
msgPtr <- c_gai_strerror e
peekCString msgPtr
eaiAgain :: AddressInfoException
eaiAgain = AddressInfoException (3)
eaiBadFlags :: AddressInfoException
eaiBadFlags = AddressInfoException (1)
eaiFail :: AddressInfoException
eaiFail = AddressInfoException (4)
eaiFamily :: AddressInfoException
eaiFamily = AddressInfoException (6)
eaiMemory :: AddressInfoException
eaiMemory = AddressInfoException (10)
eaiNoName :: AddressInfoException
eaiNoName = AddressInfoException (2)
eaiService :: AddressInfoException
eaiService = AddressInfoException (8)
eaiSocketType :: AddressInfoException
eaiSocketType = AddressInfoException (7)
eaiSystem :: AddressInfoException
eaiSystem = AddressInfoException (11)
newtype AddressInfoFlags
= AddressInfoFlags CInt
deriving (Eq, Show, Bits)
instance Monoid AddressInfoFlags where
mempty
= AddressInfoFlags 0
mappend (AddressInfoFlags a) (AddressInfoFlags b)
= AddressInfoFlags (a .|. b)
aiAddressConfig :: AddressInfoFlags
aiAddressConfig = AddressInfoFlags (32)
aiAll :: AddressInfoFlags
aiAll = AddressInfoFlags (16)
aiCanonicalName :: AddressInfoFlags
aiCanonicalName = AddressInfoFlags (2)
aiNumericHost :: AddressInfoFlags
aiNumericHost = AddressInfoFlags (4)
aiNumericService :: AddressInfoFlags
aiNumericService = AddressInfoFlags (1024)
aiPassive :: AddressInfoFlags
aiPassive = AddressInfoFlags (1)
aiV4Mapped :: AddressInfoFlags
aiV4Mapped = AddressInfoFlags (8)
newtype NameInfoFlags
= NameInfoFlags CInt
deriving (Eq, Show, Bits)
instance Monoid NameInfoFlags where
mempty
= NameInfoFlags 0
mappend (NameInfoFlags a) (NameInfoFlags b)
= NameInfoFlags (a .|. b)
niNameRequired :: NameInfoFlags
niNameRequired = NameInfoFlags (8)
niDatagram :: NameInfoFlags
niDatagram = NameInfoFlags (16)
niNoFullyQualifiedDomainName :: NameInfoFlags
niNoFullyQualifiedDomainName = NameInfoFlags (4)
niNumericHost :: NameInfoFlags
niNumericHost = NameInfoFlags (1)
niNumericService :: NameInfoFlags
niNumericService = NameInfoFlags (2)
class (Family f) => GetAddressInfo f where
getAddressInfo :: (Type t, Protocol p) => Maybe BS.ByteString -> Maybe BS.ByteString -> AddressInfoFlags -> IO [AddressInfo f t p]
instance GetAddressInfo Inet where
getAddressInfo = getAddressInfo'
instance GetAddressInfo Inet6 where
getAddressInfo = getAddressInfo'
getAddressInfo' :: forall f t p. (Family f, Type t, Protocol p) => Maybe BS.ByteString -> Maybe BS.ByteString -> AddressInfoFlags -> IO [AddressInfo f t p]
getAddressInfo' mnode mservice (AddressInfoFlags flags) = do
alloca $ \resultPtrPtr-> do
poke resultPtrPtr nullPtr
allocaBytes ((48)) $ \addrInfoPtr-> do
c_memset addrInfoPtr 0 (48)
poke (ai_flags addrInfoPtr) flags
poke (ai_family addrInfoPtr) (familyNumber (undefined :: f))
poke (ai_socktype addrInfoPtr) (typeNumber (undefined :: t))
poke (ai_protocol addrInfoPtr) (protocolNumber (undefined :: p))
fnode $ \nodePtr-> do
fservice $ \servicePtr->
bracket
(c_getaddrinfo nodePtr servicePtr addrInfoPtr resultPtrPtr)
(\_-> do resultPtr <- peek resultPtrPtr
when (resultPtr /= nullPtr) (c_freeaddrinfo resultPtr)
)
(\e-> if e == 0 then do
resultPtr <- peek resultPtrPtr
peekAddressInfos resultPtr
else do
throwIO (AddressInfoException e)
)
where
ai_flags = ((\hsc_ptr -> hsc_ptr `plusPtr` 0)) :: Ptr (AddressInfo a t p) -> Ptr CInt
ai_family = ((\hsc_ptr -> hsc_ptr `plusPtr` 4)) :: Ptr (AddressInfo a t p) -> Ptr CInt
ai_socktype = ((\hsc_ptr -> hsc_ptr `plusPtr` 8)) :: Ptr (AddressInfo a t p) -> Ptr CInt
ai_protocol = ((\hsc_ptr -> hsc_ptr `plusPtr` 12)) :: Ptr (AddressInfo a t p) -> Ptr CInt
ai_addr = ((\hsc_ptr -> hsc_ptr `plusPtr` 24)) :: Ptr (AddressInfo a t p) -> Ptr (Ptr a)
ai_canonname = ((\hsc_ptr -> hsc_ptr `plusPtr` 32)) :: Ptr (AddressInfo a t p) -> Ptr CString
ai_next = ((\hsc_ptr -> hsc_ptr `plusPtr` 40)) :: Ptr (AddressInfo a t p) -> Ptr (Ptr (AddressInfo a t p))
fnode = case mnode of
Just node -> BS.useAsCString node
Nothing -> \f-> f nullPtr
fservice = case mservice of
Just service -> BS.useAsCString service
Nothing -> \f-> f nullPtr
peekAddressInfos ptr =
if ptr == nullPtr
then return []
else do
flag <- peek (ai_flags ptr)
addr <- peek (ai_addr ptr) >>= peek
cname <- do cnPtr <- peek (ai_canonname ptr)
if cnPtr == nullPtr
then return Nothing
else BS.packCString cnPtr >>= return . Just
as <- peek (ai_next ptr) >>= peekAddressInfos
return ((AddressInfo (AddressInfoFlags flag) addr cname):as)
class (Family f) => GetNameInfo f where
getNameInfo :: SocketAddress f -> NameInfoFlags -> IO (BS.ByteString, BS.ByteString)
instance GetNameInfo Inet where
getNameInfo = getNameInfo'
instance GetNameInfo Inet6 where
getNameInfo = getNameInfo'
getNameInfo' :: Storable a => a -> NameInfoFlags -> IO (BS.ByteString, BS.ByteString)
getNameInfo' addr (NameInfoFlags flags) =
alloca $ \addrPtr->
allocaBytes (1025) $ \hostPtr->
allocaBytes (32) $ \servPtr-> do
poke addrPtr addr
e <- c_getnameinfo addrPtr (fromIntegral $ sizeOf addr)
hostPtr (1025)
servPtr (32)
flags
if e == 0 then do
host <- BS.packCString hostPtr
serv <- BS.packCString servPtr
return (host,serv)
else do
throwIO (AddressInfoException e)