{-# LANGUAGE BangPatterns       #-}
{-# LANGUAGE CPP                #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings  #-}

module Snap.Internal.Http.Server.Address
  ( getHostAddr
  , getHostAddrImpl
  , getSockAddr
  , getSockAddrImpl
  , getAddress
  , getAddressImpl
  , AddressNotSupportedException(..)
  ) where

------------------------------------------------------------------------------
#if !MIN_VERSION_base(4,8,0)
import           Control.Applicative   ((<$>))
#endif
import           Control.Exception     (Exception, throwIO)
import           Control.Monad         (liftM)
import           Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S
import           Data.Maybe            (fromMaybe)
import qualified Data.Text             as T
import qualified Data.Text.Encoding    as T
import           Data.Typeable         (Typeable)
import           Network.Socket        (AddrInfo (addrAddress, addrFamily, addrFlags, addrSocketType), AddrInfoFlag (AI_NUMERICSERV, AI_PASSIVE), Family (AF_INET, AF_INET6), HostName, NameInfoFlag (NI_NUMERICHOST), ServiceName, SockAddr (SockAddrInet, SockAddrInet6, SockAddrUnix), SocketType (Stream), defaultHints, getAddrInfo, getNameInfo)


------------------------------------------------------------------------------
data AddressNotSupportedException = AddressNotSupportedException String
   deriving (Typeable)

instance Show AddressNotSupportedException where
    show (AddressNotSupportedException x) = "Address not supported: " ++ x

instance Exception AddressNotSupportedException

------------------------------------------------------------------------------
getHostAddr :: SockAddr -> IO String
getHostAddr = getHostAddrImpl getNameInfo


------------------------------------------------------------------------------
getHostAddrImpl :: ([NameInfoFlag]
                    -> Bool
                    -> Bool
                    -> SockAddr
                    -> IO (Maybe HostName, Maybe ServiceName))
                -> SockAddr
                -> IO String
getHostAddrImpl !_getNameInfo addr =
    (fromMaybe "" . fst) `liftM` _getNameInfo [NI_NUMERICHOST] True False addr


------------------------------------------------------------------------------
getAddress :: SockAddr -> IO (Int, ByteString)
getAddress = getAddressImpl getHostAddr


------------------------------------------------------------------------------
getAddressImpl :: (SockAddr -> IO String) -> SockAddr -> IO (Int, ByteString)
getAddressImpl !_getHostAddr addr =
  case addr of
    SockAddrInet p _      -> host (fromIntegral p)
    SockAddrInet6 p _ _ _ -> host (fromIntegral p)
    SockAddrUnix path     -> return (-1, prefix path)
#if MIN_VERSION_network(2,6,0)
    _                     -> fail "Unsupported address type"
#endif
  where
    prefix path = T.encodeUtf8 $! T.pack $ "unix:" ++ path
    host port   = (,) port . S.pack <$> _getHostAddr addr


------------------------------------------------------------------------------
getSockAddr :: Int
            -> ByteString
            -> IO (Family, SockAddr)
getSockAddr = getSockAddrImpl getAddrInfo


------------------------------------------------------------------------------
getSockAddrImpl
  :: (Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo])
     -> Int -> ByteString -> IO (Family, SockAddr)
getSockAddrImpl !_getAddrInfo p s =
    case () of
      !_ | s == "*" -> getAddrs isIPv4 (Just wildhints) Nothing (Just $ show p)
         | s == "::" -> getAddrs isIPv6 (Just wildhints) Nothing (Just $ show p)
         | otherwise -> getAddrs (const True) (Just hints) (Just $ S.unpack s) (Just $ show p)

  where
    isIPv4 ai = addrFamily ai == AF_INET
    isIPv6 ai = addrFamily ai == AF_INET6

    getAddrs flt a b c = do
        ais <- filter flt <$> _getAddrInfo a b c
        if null ais
          then throwIO $ AddressNotSupportedException $ show s
          else do
            let ai = head ais
            let fm = addrFamily ai
            let sa = addrAddress ai
            return (fm, sa)

    wildhints = hints { addrFlags = [AI_NUMERICSERV, AI_PASSIVE] }
    hints = defaultHints { addrFlags = [AI_NUMERICSERV]
                         , addrSocketType = Stream
                         }
