{-# LINE 1 "src/System/Socket/Internal/AddrInfo.hsc" #-}
{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}
{-# LINE 2 "src/System/Socket/Internal/AddrInfo.hsc" #-}
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


{-# LINE 43 "src/System/Socket/Internal/AddrInfo.hsc" #-}

{-# LINE 44 "src/System/Socket/Internal/AddrInfo.hsc" #-}

{-# LINE 45 "src/System/Socket/Internal/AddrInfo.hsc" #-}

{-# LINE 46 "src/System/Socket/Internal/AddrInfo.hsc" #-}

-------------------------------------------------------------------------------
-- AddrInfo
-------------------------------------------------------------------------------

data AddrInfo a t p
   = AddrInfo
     { addrInfoFlags :: AddrInfoFlags
     , addrAddress   :: a
     , addrCanonName :: Maybe BS.ByteString
     } deriving (Eq, Show)

-------------------------------------------------------------------------------
-- AddrInfoException
-------------------------------------------------------------------------------

-- | Contains the error code that can be matched against and a readable
--   description taken from @eia_strerr@.
data AddrInfoException
   = AddrInfoException CInt String
   deriving (Eq, Show, Typeable)

instance Exception AddrInfoException

-- | Use the `Data.Monoid.Monoid` instance to combine several flags:
--
--   > mconcat [aiADDRCONFIG, aiV4MAPPED]
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)
{-# LINE 85 "src/System/Socket/Internal/AddrInfo.hsc" #-}

aiALL         :: AddrInfoFlags
aiALL          = AddrInfoFlags (16)
{-# LINE 88 "src/System/Socket/Internal/AddrInfo.hsc" #-}

aiCANONNAME   :: AddrInfoFlags
aiCANONNAME    = AddrInfoFlags (2)
{-# LINE 91 "src/System/Socket/Internal/AddrInfo.hsc" #-}

aiNUMERICHOST :: AddrInfoFlags
aiNUMERICHOST  = AddrInfoFlags (4)
{-# LINE 94 "src/System/Socket/Internal/AddrInfo.hsc" #-}

aiNUMERICSERV :: AddrInfoFlags
aiNUMERICSERV  = AddrInfoFlags (1024)
{-# LINE 97 "src/System/Socket/Internal/AddrInfo.hsc" #-}

aiPASSIVE     :: AddrInfoFlags
aiPASSIVE      = AddrInfoFlags (1)
{-# LINE 100 "src/System/Socket/Internal/AddrInfo.hsc" #-}

aiV4MAPPED    :: AddrInfoFlags
aiV4MAPPED     = AddrInfoFlags (8)
{-# LINE 103 "src/System/Socket/Internal/AddrInfo.hsc" #-}

-- | Use the `Data.Monoid.Monoid` instance to combine several flags:
--
--   > mconcat [niNAMEREQD, niNOFQDN]
newtype NameInfoFlags
      = NameInfoFlags CInt
      deriving (Eq, Show)

instance Monoid NameInfoFlags where
  mempty
    = NameInfoFlags 0
  mappend (NameInfoFlags a) (NameInfoFlags b)
    = NameInfoFlags (a .|. b)

-- | Throw an exception if the hostname cannot be determined.
niNAMEREQD     :: NameInfoFlags
niNAMEREQD      = NameInfoFlags (8)
{-# LINE 120 "src/System/Socket/Internal/AddrInfo.hsc" #-}

-- | Service is datagram based (UDP) rather than stream based (TCP).
niDGRAM        :: NameInfoFlags
niDGRAM         = NameInfoFlags (16)
{-# LINE 124 "src/System/Socket/Internal/AddrInfo.hsc" #-}

-- | Return only the hostname part of the fully qualified domain name for local hosts.
niNOFQDN       :: NameInfoFlags
niNOFQDN        = NameInfoFlags (4)
{-# LINE 128 "src/System/Socket/Internal/AddrInfo.hsc" #-}

-- | Return the numeric form of the host address.
niNUMERICHOST  :: NameInfoFlags
niNUMERICHOST   = NameInfoFlags (1)
{-# LINE 132 "src/System/Socket/Internal/AddrInfo.hsc" #-}

-- | Return the numeric form of the service address.
niNUMERICSERV  :: NameInfoFlags
niNUMERICSERV   = NameInfoFlags (2)
{-# LINE 136 "src/System/Socket/Internal/AddrInfo.hsc" #-}

-- | Maps names to addresses (i.e. by DNS lookup).
--
--   The operation throws `AddrInfoException`s.
--
--   Contrary to the underlying @getaddrinfo@ operation this wrapper is
--   typesafe and thus only returns records that match the address, type
--   and protocol encoded in the type. This is the price we have to pay
--   for typesafe sockets and extensibility.
--
--   If you need different types of records, you need to start several
--   queries. If you want to connect to both IPv4 and IPV6 addresses use
--   `aiV4MAPPED` and use IPv6-sockets.
--
--   > > getAddrInfo (Just "www.haskell.org") (Just "80") aiV4MAPPED :: IO [AddrInfo SockAddrIn6 STREAM TCP]
--   > [AddrInfo {addrInfoFlags = AddrInfoFlags 8, addrAddress = "[2400:cb00:2048:0001:0000:0000:6ca2:cc3c]:80", addrCanonName = Nothing}]
--   > > getAddrInfo (Just "darcs.haskell.org") Nothing aiV4MAPPED :: IO [AddrInfo SockAddrIn6 STREAM TCP]
--   > [AddrInfo {addrInfoFlags = AddrInfoFlags 8, addrAddress = "[0000:0000:0000:0000:0000:ffff:17fd:e1ad]:0", addrCanonName = Nothing}]
--   > > getAddrInfo (Just "darcs.haskell.org") Nothing mempty :: IO [AddrInfo SockAddrIn6 STREAM TCP]
--   > *** Exception: AddrInfoException (-2) "Name or service not known"
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
{-# LINE 164 "src/System/Socket/Internal/AddrInfo.hsc" #-}
          -- properly initialize the struct
          c_memset addrInfoPtr 0 (48)
{-# LINE 166 "src/System/Socket/Internal/AddrInfo.hsc" #-}
          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
{-# LINE 187 "src/System/Socket/Internal/AddrInfo.hsc" #-}
        ai_family    = ((\hsc_ptr -> hsc_ptr `plusPtr` 4))    :: Ptr (AddrInfo a t p) -> Ptr CInt
{-# LINE 188 "src/System/Socket/Internal/AddrInfo.hsc" #-}
        ai_socktype  = ((\hsc_ptr -> hsc_ptr `plusPtr` 8))  :: Ptr (AddrInfo a t p) -> Ptr CInt
{-# LINE 189 "src/System/Socket/Internal/AddrInfo.hsc" #-}
        ai_protocol  = ((\hsc_ptr -> hsc_ptr `plusPtr` 12))  :: Ptr (AddrInfo a t p) -> Ptr CInt
{-# LINE 190 "src/System/Socket/Internal/AddrInfo.hsc" #-}
        ai_addr      = ((\hsc_ptr -> hsc_ptr `plusPtr` 24))      :: Ptr (AddrInfo a t p) -> Ptr (Ptr a)
{-# LINE 191 "src/System/Socket/Internal/AddrInfo.hsc" #-}
        ai_canonname = ((\hsc_ptr -> hsc_ptr `plusPtr` 32)) :: Ptr (AddrInfo a t p) -> Ptr CString
{-# LINE 192 "src/System/Socket/Internal/AddrInfo.hsc" #-}
        ai_next      = ((\hsc_ptr -> hsc_ptr `plusPtr` 40))      :: Ptr (AddrInfo a t p) -> Ptr (Ptr (AddrInfo a t p))
{-# LINE 193 "src/System/Socket/Internal/AddrInfo.hsc" #-}
        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)

-- | Maps addresss to readable host- and service names.
--
--   The operation throws `AddrInfoException`s.
--
--   > > getNameInfo (SockAddrIn 80 $ pack [23,253,242,70]) mempty
--   > ("haskell.org","http")
getNameInfo :: (Address a) => a -> NameInfoFlags -> IO (BS.ByteString, BS.ByteString)
getNameInfo addr (NameInfoFlags flags) =
  alloca $ \addrPtr->
    allocaBytes (1025) $ \hostPtr->
{-# LINE 222 "src/System/Socket/Internal/AddrInfo.hsc" #-}
      allocaBytes (32) $ \servPtr-> do
{-# LINE 223 "src/System/Socket/Internal/AddrInfo.hsc" #-}
        poke addrPtr addr
        e <- c_getnameinfo addrPtr (fromIntegral $ sizeOf addr)
                           hostPtr (1025)
{-# LINE 226 "src/System/Socket/Internal/AddrInfo.hsc" #-}
                           servPtr (32)
{-# LINE 227 "src/System/Socket/Internal/AddrInfo.hsc" #-}
                           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)

-------------------------------------------------------------------------------
-- FFI
-------------------------------------------------------------------------------

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