1 {-# LANGUAGE BangPatterns       #-}
    2 {-# LANGUAGE CPP                #-}
    3 {-# LANGUAGE DeriveDataTypeable #-}
    4 {-# LANGUAGE OverloadedStrings  #-}
    5 
    6 module Snap.Internal.Http.Server.Address
    7   ( getHostAddr
    8   , getHostAddrImpl
    9   , getSockAddr
   10   , getSockAddrImpl
   11   , getAddress
   12   , getAddressImpl
   13   , AddressNotSupportedException(..)
   14   ) where
   15 
   16 ------------------------------------------------------------------------------
   17 #if !MIN_VERSION_base(4,8,0)
   18 import           Control.Applicative   ((<$>))
   19 #endif
   20 import           Control.Exception     (Exception, throwIO)
   21 import           Control.Monad         (liftM)
   22 import           Data.ByteString.Char8 (ByteString)
   23 import qualified Data.ByteString.Char8 as S
   24 import           Data.Maybe            (fromMaybe)
   25 import qualified Data.Text             as T
   26 import qualified Data.Text.Encoding    as T
   27 import           Data.Typeable         (Typeable)
   28 import           Network.Socket        (AddrInfo (addrAddress, addrFamily, addrSocketType, addrFlags), AddrInfoFlag (AI_NUMERICSERV), Family (AF_INET, AF_INET6), HostName, NameInfoFlag (NI_NUMERICHOST), ServiceName, SockAddr (SockAddrInet, SockAddrInet6, SockAddrUnix), SocketType (Stream), defaultHints, getAddrInfo, getNameInfo, iN6ADDR_ANY, iNADDR_ANY)
   29 
   30 
   31 ------------------------------------------------------------------------------
   32 data AddressNotSupportedException = AddressNotSupportedException String
   33    deriving (Typeable)
   34 
   35 instance Show AddressNotSupportedException where
   36     show (AddressNotSupportedException x) = "Address not supported: " ++ x
   37 
   38 instance Exception AddressNotSupportedException
   39 
   40 ------------------------------------------------------------------------------
   41 getHostAddr :: SockAddr -> IO String
   42 getHostAddr = getHostAddrImpl getNameInfo
   43 
   44 
   45 ------------------------------------------------------------------------------
   46 getHostAddrImpl :: ([NameInfoFlag]
   47                     -> Bool
   48                     -> Bool
   49                     -> SockAddr
   50                     -> IO (Maybe HostName, Maybe ServiceName))
   51                 -> SockAddr
   52                 -> IO String
   53 getHostAddrImpl !_getNameInfo addr =
   54     (fromMaybe "" . fst) `liftM` _getNameInfo [NI_NUMERICHOST] True False addr
   55 
   56 
   57 ------------------------------------------------------------------------------
   58 getAddress :: SockAddr -> IO (Int, ByteString)
   59 getAddress = getAddressImpl getHostAddr
   60 
   61 
   62 ------------------------------------------------------------------------------
   63 getAddressImpl :: (SockAddr -> IO String) -> SockAddr -> IO (Int, ByteString)
   64 getAddressImpl !_getHostAddr addr =
   65   case addr of
   66     SockAddrInet p _      -> host (fromIntegral p)
   67     SockAddrInet6 p _ _ _ -> host (fromIntegral p)
   68     SockAddrUnix path     -> return (-1, prefix path)
   69 #if MIN_VERSION_network(2,6,0)
   70     _                     -> fail "Unsupported address type"
   71 #endif
   72   where
   73     prefix path = T.encodeUtf8 $! T.pack $ "unix:" ++ path
   74     host port   = (,) port . S.pack <$> _getHostAddr addr
   75 
   76 
   77 ------------------------------------------------------------------------------
   78 getSockAddr :: Int
   79             -> ByteString
   80             -> IO (Family, SockAddr)
   81 getSockAddr = getSockAddrImpl getAddrInfo
   82 
   83 
   84 ------------------------------------------------------------------------------
   85 getSockAddrImpl
   86   :: (Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo])
   87      -> Int -> ByteString -> IO (Family, SockAddr)
   88 getSockAddrImpl !_getAddrInfo p s =
   89     case () of
   90       !_ | s == "*" -> return $! ( AF_INET
   91                                  , SockAddrInet (fromIntegral p) iNADDR_ANY
   92                                  )
   93          | s == "::" -> return $! ( AF_INET6
   94                                   , SockAddrInet6 (fromIntegral p) 0 iN6ADDR_ANY 0
   95                                   )
   96          | otherwise -> do ais <- _getAddrInfo (Just hints) (Just $ S.unpack s)
   97                                                (Just $ show p)
   98                            if null ais
   99                              then throwIO $ AddressNotSupportedException $ show s
  100                              else do
  101                                let ai = head ais
  102                                let fm = addrFamily ai
  103                                let sa = addrAddress ai
  104                                return (fm, sa)
  105   where
  106     hints = defaultHints { addrFlags = [AI_NUMERICSERV]
  107                          , addrSocketType = Stream
  108                          }