{-# 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 :: Word32 -> String
showHostAddress Word32
num = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Word32 -> String
forall a. Show a => a -> String
show Word32
q1, String
".", Word32 -> String
forall a. Show a => a -> String
show Word32
q2, String
".", Word32 -> String
forall a. Show a => a -> String
show Word32
q3, String
".", Word32 -> String
forall a. Show a => a -> String
show Word32
q4]
  where (Word32
num',Word32
q1)   = Word32
num Word32 -> Word32 -> (Word32, Word32)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Word32
256
        (Word32
num'',Word32
q2)  = Word32
num' Word32 -> Word32 -> (Word32, Word32)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Word32
256
        (Word32
num''',Word32
q3) = Word32
num'' Word32 -> Word32 -> (Word32, Word32)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Word32
256
        (Word32
_,Word32
q4)      = Word32
num''' Word32 -> Word32 -> (Word32, Word32)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Word32
256

-- | Converts a IPv6 HostAddress6 to standard hex notation
showHostAddress6 :: HostAddress6 -> String
showHostAddress6 :: HostAddress6 -> String
showHostAddress6 (Word32
a,Word32
b,Word32
c,Word32
d) =
  ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String)
-> ([Word32] -> [String]) -> [Word32] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
":" ([String] -> [String])
-> ([Word32] -> [String]) -> [Word32] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word32 -> String) -> [Word32] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Word32 -> String -> String) -> String -> Word32 -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip Word32 -> String -> String
forall a. Integral a => a -> String -> String
showHex String
""))
    [Word32
p1,Word32
p2,Word32
p3,Word32
p4,Word32
p5,Word32
p6,Word32
p7,Word32
p8]
  where (Word32
a',Word32
p2) = Word32
a Word32 -> Word32 -> (Word32, Word32)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Word32
65536
        (Word32
_,Word32
p1)  = Word32
a' Word32 -> Word32 -> (Word32, Word32)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Word32
65536
        (Word32
b',Word32
p4) = Word32
b Word32 -> Word32 -> (Word32, Word32)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Word32
65536
        (Word32
_,Word32
p3)  = Word32
b' Word32 -> Word32 -> (Word32, Word32)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Word32
65536
        (Word32
c',Word32
p6) = Word32
c Word32 -> Word32 -> (Word32, Word32)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Word32
65536
        (Word32
_,Word32
p5)  = Word32
c' Word32 -> Word32 -> (Word32, Word32)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Word32
65536
        (Word32
d',Word32
p8) = Word32
d Word32 -> Word32 -> (Word32, Word32)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Word32
65536
        (Word32
_,Word32
p7)  = Word32
d' Word32 -> Word32 -> (Word32, Word32)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Word32
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 Socket
sock = do
  (Socket
sock', SockAddr
addr) <- Socket -> IO (Socket, SockAddr)
S.accept Socket
sock
  let (String
peer, PortNumber
port) = SockAddr -> (String, PortNumber)
sockAddrToPeer SockAddr
addr
  (Socket, String, PortNumber) -> IO (Socket, String, PortNumber)
forall a. a -> IO a
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 SockAddr
addr =
  case SockAddr
addr of
    (S.SockAddrInet PortNumber
p Word32
ha)      -> (Word32 -> String
showHostAddress Word32
ha, PortNumber
p)
    (S.SockAddrInet6 PortNumber
p Word32
_ HostAddress6
ha Word32
_) -> (HostAddress6 -> String
showHostAddress6 HostAddress6
ha, PortNumber
p)
    SockAddr
_                          -> String -> (String, PortNumber)
forall a. HasCallStack => String -> a
error String
"sockAddrToPeer: Unsupported socket type"