{-# LANGUAGE CPP #-}
module Happstack.Server.Internal.Socket
    ( acceptLite
    , sockAddrToPeer
    ) where

import Data.List (intersperse)
import Data.Word (Word32)
import qualified Network.Socket as S
  ( Socket
  , PortNumber()
  , SockAddr(..)
  , HostName
  , accept
  )
import Numeric (showHex)

type HostAddress = Word32
type HostAddress6 = (Word32, Word32, Word32, Word32)

-- | Converts a HostAddress to a String in dot-decimal notation
showHostAddress :: HostAddress -> String
showHostAddress :: HostAddress -> String
showHostAddress num :: HostAddress
num = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [HostAddress -> String
forall a. Show a => a -> String
show HostAddress
q1, ".", HostAddress -> String
forall a. Show a => a -> String
show HostAddress
q2, ".", HostAddress -> String
forall a. Show a => a -> String
show HostAddress
q3, ".", HostAddress -> String
forall a. Show a => a -> String
show HostAddress
q4]
  where (num' :: HostAddress
num',q1 :: HostAddress
q1)   = HostAddress
num HostAddress -> HostAddress -> (HostAddress, HostAddress)
forall a. Integral a => a -> a -> (a, a)
`quotRem` 256
        (num'' :: HostAddress
num'',q2 :: HostAddress
q2)  = HostAddress
num' HostAddress -> HostAddress -> (HostAddress, HostAddress)
forall a. Integral a => a -> a -> (a, a)
`quotRem` 256
        (num''' :: HostAddress
num''',q3 :: HostAddress
q3) = HostAddress
num'' HostAddress -> HostAddress -> (HostAddress, HostAddress)
forall a. Integral a => a -> a -> (a, a)
`quotRem` 256
        (_,q4 :: HostAddress
q4)      = HostAddress
num''' HostAddress -> HostAddress -> (HostAddress, HostAddress)
forall a. Integral a => a -> a -> (a, a)
`quotRem` 256

-- | Converts a IPv6 HostAddress6 to standard hex notation
showHostAddress6 :: HostAddress6 -> String
showHostAddress6 :: HostAddress6 -> String
showHostAddress6 (a :: HostAddress
a,b :: HostAddress
b,c :: HostAddress
c,d :: HostAddress
d) =
  ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String)
-> ([HostAddress] -> [String]) -> [HostAddress] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse ":" ([String] -> [String])
-> ([HostAddress] -> [String]) -> [HostAddress] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HostAddress -> String) -> [HostAddress] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((HostAddress -> String -> String)
-> String -> HostAddress -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip HostAddress -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex ""))
    [HostAddress
p1,HostAddress
p2,HostAddress
p3,HostAddress
p4,HostAddress
p5,HostAddress
p6,HostAddress
p7,HostAddress
p8]
  where (a' :: HostAddress
a',p2 :: HostAddress
p2) = HostAddress
a HostAddress -> HostAddress -> (HostAddress, HostAddress)
forall a. Integral a => a -> a -> (a, a)
`quotRem` 65536
        (_,p1 :: HostAddress
p1)  = HostAddress
a' HostAddress -> HostAddress -> (HostAddress, HostAddress)
forall a. Integral a => a -> a -> (a, a)
`quotRem` 65536
        (b' :: HostAddress
b',p4 :: HostAddress
p4) = HostAddress
b HostAddress -> HostAddress -> (HostAddress, HostAddress)
forall a. Integral a => a -> a -> (a, a)
`quotRem` 65536
        (_,p3 :: HostAddress
p3)  = HostAddress
b' HostAddress -> HostAddress -> (HostAddress, HostAddress)
forall a. Integral a => a -> a -> (a, a)
`quotRem` 65536
        (c' :: HostAddress
c',p6 :: HostAddress
p6) = HostAddress
c HostAddress -> HostAddress -> (HostAddress, HostAddress)
forall a. Integral a => a -> a -> (a, a)
`quotRem` 65536
        (_,p5 :: HostAddress
p5)  = HostAddress
c' HostAddress -> HostAddress -> (HostAddress, HostAddress)
forall a. Integral a => a -> a -> (a, a)
`quotRem` 65536
        (d' :: HostAddress
d',p8 :: HostAddress
p8) = HostAddress
d HostAddress -> HostAddress -> (HostAddress, HostAddress)
forall a. Integral a => a -> a -> (a, a)
`quotRem` 65536
        (_,p7 :: HostAddress
p7)  = HostAddress
d' HostAddress -> HostAddress -> (HostAddress, HostAddress)
forall a. Integral a => a -> a -> (a, a)
`quotRem` 65536

-- | alternative implementation of accept to work around EAI_AGAIN errors
acceptLite :: S.Socket -> IO (S.Socket, S.HostName, S.PortNumber)
acceptLite :: Socket -> IO (Socket, String, PortNumber)
acceptLite sock :: Socket
sock = do
  (sock' :: Socket
sock', addr :: SockAddr
addr) <- Socket -> IO (Socket, SockAddr)
S.accept Socket
sock
  let (peer :: String
peer, port :: PortNumber
port) = SockAddr -> (String, PortNumber)
sockAddrToPeer SockAddr
addr
  (Socket, String, PortNumber) -> IO (Socket, String, PortNumber)
forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
sock', String
peer, PortNumber
port)

sockAddrToPeer ::  S.SockAddr -> (S.HostName, S.PortNumber)
sockAddrToPeer :: SockAddr -> (String, PortNumber)
sockAddrToPeer addr :: SockAddr
addr =
  case SockAddr
addr of
    (S.SockAddrInet p :: PortNumber
p ha :: HostAddress
ha)      -> (HostAddress -> String
showHostAddress HostAddress
ha, PortNumber
p)
    (S.SockAddrInet6 p :: PortNumber
p _ ha :: HostAddress6
ha _) -> (HostAddress6 -> String
showHostAddress6 HostAddress6
ha, PortNumber
p)
    _                          -> String -> (String, PortNumber)
forall a. HasCallStack => String -> a
error "sockAddrToPeer: Unsupported socket type"