module System.Socket.Internal.AddrInfo (
AddrInfo (..)
, AddrInfoException (..)
, getAddrInfo
, getNameInfo
, AddrInfoFlags (..)
, aiADDRCONFIG
, aiALL
, aiCANONNAME
, aiNUMERICHOST
, aiNUMERICSERV
, aiPASSIVE
, aiV4MAPPED
, NameInfoFlags (..)
, niNAMEREQD
, niDGRAM
, niNOFQDN
, niNUMERICHOST
, niNUMERICSERV
) 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.Socket.Address
import System.Socket.Type
import System.Socket.Protocol
import System.Socket.Internal.FFI
data AddrInfo a t p
= AddrInfo
{ addrInfoFlags :: AddrInfoFlags
, addrAddress :: a
, addrCanonName :: Maybe BS.ByteString
} deriving (Eq, Show)
data AddrInfoException
= AddrInfoException CInt String
deriving (Eq, Show, Typeable)
instance Exception AddrInfoException
newtype AddrInfoFlags
= AddrInfoFlags CInt
deriving (Eq, Show)
instance Monoid AddrInfoFlags where
mempty
= AddrInfoFlags 0
mappend (AddrInfoFlags a) (AddrInfoFlags b)
= AddrInfoFlags (a .|. b)
aiADDRCONFIG :: AddrInfoFlags
aiADDRCONFIG = AddrInfoFlags (32)
aiALL :: AddrInfoFlags
aiALL = AddrInfoFlags (16)
aiCANONNAME :: AddrInfoFlags
aiCANONNAME = AddrInfoFlags (2)
aiNUMERICHOST :: AddrInfoFlags
aiNUMERICHOST = AddrInfoFlags (4)
aiNUMERICSERV :: AddrInfoFlags
aiNUMERICSERV = AddrInfoFlags (1024)
aiPASSIVE :: AddrInfoFlags
aiPASSIVE = AddrInfoFlags (1)
aiV4MAPPED :: AddrInfoFlags
aiV4MAPPED = AddrInfoFlags (8)
newtype NameInfoFlags
= NameInfoFlags CInt
deriving (Eq, Show)
instance Monoid NameInfoFlags where
mempty
= NameInfoFlags 0
mappend (NameInfoFlags a) (NameInfoFlags b)
= NameInfoFlags (a .|. b)
niNAMEREQD :: NameInfoFlags
niNAMEREQD = NameInfoFlags (8)
niDGRAM :: NameInfoFlags
niDGRAM = NameInfoFlags (16)
niNOFQDN :: NameInfoFlags
niNOFQDN = NameInfoFlags (4)
niNUMERICHOST :: NameInfoFlags
niNUMERICHOST = NameInfoFlags (1)
niNUMERICSERV :: NameInfoFlags
niNUMERICSERV = NameInfoFlags (2)
getAddrInfo :: (Address a, Type t, Protocol p) => Maybe BS.ByteString -> Maybe BS.ByteString -> AddrInfoFlags -> IO [AddrInfo a t p]
getAddrInfo = getAddrInfo'
where
getAddrInfo' :: forall a t p. (Address a, Type t, Protocol p) => Maybe BS.ByteString -> Maybe BS.ByteString -> AddrInfoFlags -> IO [AddrInfo a t p]
getAddrInfo' mnode mservice (AddrInfoFlags 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) (addressFamilyNumber (undefined :: a))
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
peekAddrInfos resultPtr
else do
msgPtr <- c_gaistrerror e
msg <- peekCString msgPtr
throwIO (AddrInfoException e msg)
)
where
ai_flags = ((\hsc_ptr -> hsc_ptr `plusPtr` 0)) :: Ptr (AddrInfo a t p) -> Ptr CInt
ai_family = ((\hsc_ptr -> hsc_ptr `plusPtr` 4)) :: Ptr (AddrInfo a t p) -> Ptr CInt
ai_socktype = ((\hsc_ptr -> hsc_ptr `plusPtr` 8)) :: Ptr (AddrInfo a t p) -> Ptr CInt
ai_protocol = ((\hsc_ptr -> hsc_ptr `plusPtr` 12)) :: Ptr (AddrInfo a t p) -> Ptr CInt
ai_addr = ((\hsc_ptr -> hsc_ptr `plusPtr` 24)) :: Ptr (AddrInfo a t p) -> Ptr (Ptr a)
ai_canonname = ((\hsc_ptr -> hsc_ptr `plusPtr` 32)) :: Ptr (AddrInfo a t p) -> Ptr CString
ai_next = ((\hsc_ptr -> hsc_ptr `plusPtr` 40)) :: Ptr (AddrInfo a t p) -> Ptr (Ptr (AddrInfo 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
peekAddrInfos 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) >>= peekAddrInfos
return ((AddrInfo (AddrInfoFlags flag) addr cname):as)
getNameInfo :: (Address 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
msgPtr <- c_gaistrerror e
msg <- peekCString msgPtr
throwIO (AddrInfoException e msg)
foreign import ccall safe "netdb.h getaddrinfo"
c_getaddrinfo :: CString -> CString -> Ptr (AddrInfo a t p) -> Ptr (Ptr (AddrInfo a t p)) -> IO CInt
foreign import ccall unsafe "netdb.h freeaddrinfo"
c_freeaddrinfo :: Ptr (AddrInfo a t p) -> IO ()
foreign import ccall safe "netdb.h getnameinfo"
c_getnameinfo :: Ptr a -> CInt -> CString -> CInt -> CString -> CInt -> CInt -> IO CInt
foreign import ccall unsafe "netdb.h gai_strerror"
c_gaistrerror :: CInt -> IO CString