{-# 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: " 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 =
    (forall a. a -> Maybe a -> a
fromMaybe String
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) 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
_      -> forall {a}. a -> IO (a, ByteString)
host (forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
p)
    SockAddrInet6 PortNumber
p HostAddress
_ HostAddress6
_ HostAddress
_ -> forall {a}. a -> IO (a, ByteString)
host (forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
p)
    SockAddrUnix String
path     -> forall (m :: * -> *) a. Monad m => a -> m a
return (-Int
1, String -> ByteString
prefix String
path)
#if MIN_VERSION_network(2,6,0)
    SockAddr
_                     -> 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 forall a b. (a -> b) -> a -> b
$! String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
"unix:" forall a. [a] -> [a] -> [a]
++ String
path
    host :: a -> IO (a, ByteString)
host a
port   = (,) a
port forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
S.pack 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 forall a. Eq a => a -> a -> Bool
== ByteString
"*" -> (AddrInfo -> Bool)
-> Maybe AddrInfo
-> Maybe String
-> Maybe String
-> IO (Family, SockAddr)
getAddrs AddrInfo -> Bool
isIPv4 (forall a. a -> Maybe a
Just AddrInfo
wildhints) forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
p)
         | ByteString
s forall a. Eq a => a -> a -> Bool
== ByteString
"::" -> (AddrInfo -> Bool)
-> Maybe AddrInfo
-> Maybe String
-> Maybe String
-> IO (Family, SockAddr)
getAddrs AddrInfo -> Bool
isIPv6 (forall a. a -> Maybe a
Just AddrInfo
wildhints) forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
p)
         | Bool
otherwise -> (AddrInfo -> Bool)
-> Maybe AddrInfo
-> Maybe String
-> Maybe String
-> IO (Family, SockAddr)
getAddrs (forall a b. a -> b -> a
const Bool
True) (forall a. a -> Maybe a
Just AddrInfo
hints) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> String
S.unpack ByteString
s) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
p)

  where
    isIPv4 :: AddrInfo -> Bool
isIPv4 AddrInfo
ai = AddrInfo -> Family
addrFamily AddrInfo
ai forall a. Eq a => a -> a -> Bool
== Family
AF_INET
    isIPv6 :: AddrInfo -> Bool
isIPv6 AddrInfo
ai = AddrInfo -> Family
addrFamily AddrInfo
ai 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 <- forall a. (a -> Bool) -> [a] -> [a]
filter AddrInfo -> Bool
flt 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AddrInfo]
ais
          then forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> AddressNotSupportedException
AddressNotSupportedException forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ByteString
s
          else do
            let ai :: AddrInfo
ai = 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
            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
                         }