{-# 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 -> String
show (AddressNotSupportedException String
x) = String
"Address not supported: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x

instance Exception AddressNotSupportedException

------------------------------------------------------------------------------
getHostAddr :: SockAddr -> IO String
getHostAddr :: SockAddr -> IO String
getHostAddr = ([NameInfoFlag]
 -> Bool -> Bool -> SockAddr -> IO (Maybe String, Maybe String))
-> SockAddr -> IO String
getHostAddrImpl [NameInfoFlag]
-> Bool -> Bool -> SockAddr -> IO (Maybe String, Maybe String)
getNameInfo


------------------------------------------------------------------------------
getHostAddrImpl :: ([NameInfoFlag]
                    -> Bool
                    -> Bool
                    -> SockAddr
                    -> IO (Maybe HostName, Maybe ServiceName))
                -> SockAddr
                -> IO String
getHostAddrImpl :: ([NameInfoFlag]
 -> Bool -> Bool -> SockAddr -> IO (Maybe String, Maybe String))
-> SockAddr -> IO String
getHostAddrImpl ![NameInfoFlag]
-> Bool -> Bool -> SockAddr -> IO (Maybe String, Maybe String)
_getNameInfo SockAddr
addr =
    (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String)
-> ((Maybe String, Maybe String) -> Maybe String)
-> (Maybe String, Maybe String)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe String, Maybe String) -> Maybe String
forall a b. (a, b) -> a
fst) ((Maybe String, Maybe String) -> String)
-> IO (Maybe String, Maybe String) -> IO String
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` [NameInfoFlag]
-> Bool -> Bool -> SockAddr -> IO (Maybe String, Maybe String)
_getNameInfo [NameInfoFlag
NI_NUMERICHOST] Bool
True Bool
False SockAddr
addr


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


------------------------------------------------------------------------------
getAddressImpl :: (SockAddr -> IO String) -> SockAddr -> IO (Int, ByteString)
getAddressImpl :: (SockAddr -> IO String) -> SockAddr -> IO (Int, ByteString)
getAddressImpl !SockAddr -> IO String
_getHostAddr SockAddr
addr =
  case SockAddr
addr of
    SockAddrInet PortNumber
p HostAddress
_      -> Int -> IO (Int, ByteString)
forall a. a -> IO (a, ByteString)
host (PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
p)
    SockAddrInet6 PortNumber
p HostAddress
_ HostAddress6
_ HostAddress
_ -> Int -> IO (Int, ByteString)
forall a. a -> IO (a, ByteString)
host (PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
p)
    SockAddrUnix String
path     -> (Int, ByteString) -> IO (Int, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (-Int
1, String -> ByteString
prefix String
path)
#if MIN_VERSION_network(2,6,0)
    SockAddr
_                     -> String -> IO (Int, ByteString)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported address type"
#endif
  where
    prefix :: String -> ByteString
prefix String
path = Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$! String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"unix:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
path
    host :: a -> IO (a, ByteString)
host a
port   = (,) a
port (ByteString -> (a, ByteString))
-> (String -> ByteString) -> String -> (a, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
S.pack (String -> (a, ByteString)) -> IO String -> IO (a, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SockAddr -> IO String
_getHostAddr SockAddr
addr


------------------------------------------------------------------------------
getSockAddr :: Int
            -> ByteString
            -> IO (Family, SockAddr)
getSockAddr :: Int -> ByteString -> IO (Family, SockAddr)
getSockAddr = (Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo])
-> Int -> ByteString -> IO (Family, SockAddr)
getSockAddrImpl Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo


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

  where
    isIPv4 :: AddrInfo -> Bool
isIPv4 AddrInfo
ai = AddrInfo -> Family
addrFamily AddrInfo
ai Family -> Family -> Bool
forall a. Eq a => a -> a -> Bool
== Family
AF_INET
    isIPv6 :: AddrInfo -> Bool
isIPv6 AddrInfo
ai = AddrInfo -> Family
addrFamily AddrInfo
ai Family -> Family -> Bool
forall a. Eq a => a -> a -> Bool
== Family
AF_INET6

    getAddrs :: (AddrInfo -> Bool)
-> Maybe AddrInfo
-> Maybe String
-> Maybe String
-> IO (Family, SockAddr)
getAddrs AddrInfo -> Bool
flt Maybe AddrInfo
a Maybe String
b Maybe String
c = do
        [AddrInfo]
ais <- (AddrInfo -> Bool) -> [AddrInfo] -> [AddrInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter AddrInfo -> Bool
flt ([AddrInfo] -> [AddrInfo]) -> IO [AddrInfo] -> IO [AddrInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
_getAddrInfo Maybe AddrInfo
a Maybe String
b Maybe String
c
        if [AddrInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AddrInfo]
ais
          then AddressNotSupportedException -> IO (Family, SockAddr)
forall e a. Exception e => e -> IO a
throwIO (AddressNotSupportedException -> IO (Family, SockAddr))
-> AddressNotSupportedException -> IO (Family, SockAddr)
forall a b. (a -> b) -> a -> b
$ String -> AddressNotSupportedException
AddressNotSupportedException (String -> AddressNotSupportedException)
-> String -> AddressNotSupportedException
forall a b. (a -> b) -> a -> b
$ ByteString -> String
forall a. Show a => a -> String
show ByteString
s
          else do
            let ai :: AddrInfo
ai = [AddrInfo] -> AddrInfo
forall a. [a] -> a
head [AddrInfo]
ais
            let fm :: Family
fm = AddrInfo -> Family
addrFamily AddrInfo
ai
            let sa :: SockAddr
sa = AddrInfo -> SockAddr
addrAddress AddrInfo
ai
            (Family, SockAddr) -> IO (Family, SockAddr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Family
fm, SockAddr
sa)

    wildhints :: AddrInfo
wildhints = AddrInfo
hints { addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_NUMERICSERV, AddrInfoFlag
AI_PASSIVE] }
    hints :: AddrInfo
hints = AddrInfo
defaultHints { addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_NUMERICSERV]
                         , addrSocketType :: SocketType
addrSocketType = SocketType
Stream
                         }