--
-- copied from https://github.com/input-output-hk/ouroboros-network
--
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.BM.Snocket
  ( -- * Snocket Interface
    Accept (..)
  , fmapAccept
  , mkListeningSocket
  , AddressFamily (..)
  , Snocket (..)
    -- ** Socket based Snocktes
  , SocketSnocket
  , socketSnocket
    -- ** Local Snockets
    -- Using unix sockets (posix) or named pipes (windows)
    --
  , LocalSnocket
  , localSnocket
  , LocalAddress (..)
  , LocalFD
  , localAddressFromPath
  , localFDToHandle
  ) where

import           Control.Exception
import           Control.Monad (when)
import           Network.Socket (SockAddr (..), Socket)
import qualified Network.Socket as Socket
#if defined(mingw32_HOST_OS)
import           Data.Bits
import qualified System.Win32 as Win32
import qualified System.Win32.Async as Win32.Async
import qualified System.Win32.NamedPipes as Win32
import           System.Win32.Types (hANDLEToHandle)
#endif

import qualified System.IO as IO

import           Cardano.BM.IOManager


-- | Named pipes and Berkeley sockets have different API when accepting
-- a connection.  For named pipes the file descriptor created by 'createNamedPipe' is
-- supposed to be used for the first connected client.  Named pipe accept loop
-- looks this way:
--
-- > acceptLoop k = do
-- >   h <- createNamedPipe name
-- >   connectNamedPipe h
-- >   -- h is now in connected state
-- >   forkIO (k h)
-- >   acceptLoop k
--
-- For Berkeley sockets equivalent loop starts by creating a socket
-- which accepts connections and accept returns a new socket in connected
-- state
--
-- > acceptLoop k = do
-- >     s <- socket ...
-- >     bind s address
-- >     listen s
-- >     loop s
-- >   where
-- >     loop s = do
-- >       (s' , _addr') <- accept s
-- >       -- s' is in connected state
-- >       forkIO (k s')
-- >       loop s
--
-- To make common API for both we use a recursive type 'Accept', see
-- 'berkeleyAccept' below.  Creation of a socket / named pipe is part of
-- 'Snocket', but this means we need to have different recursion step for named
-- pipe & sockets.  For sockets its recursion step will always return 'accept'
-- syscall; for named pipes the first callback will reuse the file descriptor
-- created by 'open' and only subsequent calls will create a new file
-- descriptor by `createNamedPipe`, see 'namedPipeSnocket'.
--
newtype Accept addr fd = Accept
  { Accept addr fd -> IO (fd, addr, Accept addr fd)
runAccept :: IO (fd, addr, Accept addr fd)
  }


-- | Arguments of 'Accept' are in the wrong order.
--
-- TODO: this can be fixed later.
--
fmapAccept :: (addr -> addr') -> Accept addr fd -> Accept addr' fd
fmapAccept :: (addr -> addr') -> Accept addr fd -> Accept addr' fd
fmapAccept addr -> addr'
f Accept addr fd
ac = IO (fd, addr', Accept addr' fd) -> Accept addr' fd
forall addr fd. IO (fd, addr, Accept addr fd) -> Accept addr fd
Accept (IO (fd, addr', Accept addr' fd) -> Accept addr' fd)
-> IO (fd, addr', Accept addr' fd) -> Accept addr' fd
forall a b. (a -> b) -> a -> b
$ (fd, addr, Accept addr fd) -> (fd, addr', Accept addr' fd)
g ((fd, addr, Accept addr fd) -> (fd, addr', Accept addr' fd))
-> IO (fd, addr, Accept addr fd) -> IO (fd, addr', Accept addr' fd)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Accept addr fd -> IO (fd, addr, Accept addr fd)
forall addr fd. Accept addr fd -> IO (fd, addr, Accept addr fd)
runAccept Accept addr fd
ac
  where
    g :: (fd, addr, Accept addr fd) -> (fd, addr', Accept addr' fd)
g (fd
fd, addr
addr, Accept addr fd
next) = (fd
fd, addr -> addr'
f addr
addr, (addr -> addr') -> Accept addr fd -> Accept addr' fd
forall addr addr' fd.
(addr -> addr') -> Accept addr fd -> Accept addr' fd
fmapAccept addr -> addr'
f Accept addr fd
next)


mkListeningSocket
    :: Snocket IO fd addr
    -> Maybe addr
    -> AddressFamily addr
    -> IO fd
mkListeningSocket :: Snocket IO fd addr -> Maybe addr -> AddressFamily addr -> IO fd
mkListeningSocket Snocket IO fd addr
sn Maybe addr
addr AddressFamily addr
family_ = do
    fd
sd <- Snocket IO fd addr -> AddressFamily addr -> IO fd
forall (m :: * -> *) fd addr.
Snocket m fd addr -> AddressFamily addr -> m fd
open Snocket IO fd addr
sn AddressFamily addr
family_

    case Maybe addr
addr of
      Maybe addr
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just addr
addr_ -> do
        Snocket IO fd addr -> fd -> addr -> IO ()
forall (m :: * -> *) fd addr.
Snocket m fd addr -> fd -> addr -> m ()
bind Snocket IO fd addr
sn fd
sd addr
addr_
        Snocket IO fd addr -> fd -> IO ()
forall (m :: * -> *) fd addr. Snocket m fd addr -> fd -> m ()
listen Snocket IO fd addr
sn fd
sd
    fd -> IO fd
forall (f :: * -> *) a. Applicative f => a -> f a
pure fd
sd

-- | BSD accept loop.
--
berkeleyAccept :: IOManager
               -> Socket
               -> Accept SockAddr Socket
berkeleyAccept :: IOManager -> Socket -> Accept SockAddr Socket
berkeleyAccept IOManager
ioManager Socket
sock = Accept SockAddr Socket
go
    where
      go :: Accept SockAddr Socket
go = IO (Socket, SockAddr, Accept SockAddr Socket)
-> Accept SockAddr Socket
forall addr fd. IO (fd, addr, Accept addr fd) -> Accept addr fd
Accept (IO (Socket, SockAddr, Accept SockAddr Socket)
 -> Accept SockAddr Socket)
-> IO (Socket, SockAddr, Accept SockAddr Socket)
-> Accept SockAddr Socket
forall a b. (a -> b) -> a -> b
$ do
        (Socket
sock', SockAddr
addr') <-
#if !defined(mingw32_HOST_OS)
          Socket -> IO (Socket, SockAddr)
Socket.accept Socket
sock
#else
          Win32.Async.accept sock
#endif
        IOManager -> Either Any Socket -> IO ()
IOManager -> forall hole. hole -> IO ()
associateWithIOManager IOManager
ioManager (Socket -> Either Any Socket
forall a b. b -> Either a b
Right Socket
sock')
          IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
e :: IOException) -> do
            Socket -> IO ()
Socket.close Socket
sock'
            IOException -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOException
e
          IO () -> (SomeAsyncException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeAsyncException e
_) -> do
            Socket -> IO ()
Socket.close Socket
sock'
            IOException -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOException
e
        (Socket, SockAddr, Accept SockAddr Socket)
-> IO (Socket, SockAddr, Accept SockAddr Socket)
forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
sock', SockAddr
addr', Accept SockAddr Socket
go)

-- | Local address, on Unix is associated with `Socket.AF_UNIX` family, on
--
-- Windows with `named-pipes`.
--
newtype LocalAddress = LocalAddress { LocalAddress -> FilePath
getFilePath :: FilePath }
  deriving (Int -> LocalAddress -> ShowS
[LocalAddress] -> ShowS
LocalAddress -> FilePath
(Int -> LocalAddress -> ShowS)
-> (LocalAddress -> FilePath)
-> ([LocalAddress] -> ShowS)
-> Show LocalAddress
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [LocalAddress] -> ShowS
$cshowList :: [LocalAddress] -> ShowS
show :: LocalAddress -> FilePath
$cshow :: LocalAddress -> FilePath
showsPrec :: Int -> LocalAddress -> ShowS
$cshowsPrec :: Int -> LocalAddress -> ShowS
Show, LocalAddress -> LocalAddress -> Bool
(LocalAddress -> LocalAddress -> Bool)
-> (LocalAddress -> LocalAddress -> Bool) -> Eq LocalAddress
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LocalAddress -> LocalAddress -> Bool
$c/= :: LocalAddress -> LocalAddress -> Bool
== :: LocalAddress -> LocalAddress -> Bool
$c== :: LocalAddress -> LocalAddress -> Bool
Eq, Eq LocalAddress
Eq LocalAddress
-> (LocalAddress -> LocalAddress -> Ordering)
-> (LocalAddress -> LocalAddress -> Bool)
-> (LocalAddress -> LocalAddress -> Bool)
-> (LocalAddress -> LocalAddress -> Bool)
-> (LocalAddress -> LocalAddress -> Bool)
-> (LocalAddress -> LocalAddress -> LocalAddress)
-> (LocalAddress -> LocalAddress -> LocalAddress)
-> Ord LocalAddress
LocalAddress -> LocalAddress -> Bool
LocalAddress -> LocalAddress -> Ordering
LocalAddress -> LocalAddress -> LocalAddress
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LocalAddress -> LocalAddress -> LocalAddress
$cmin :: LocalAddress -> LocalAddress -> LocalAddress
max :: LocalAddress -> LocalAddress -> LocalAddress
$cmax :: LocalAddress -> LocalAddress -> LocalAddress
>= :: LocalAddress -> LocalAddress -> Bool
$c>= :: LocalAddress -> LocalAddress -> Bool
> :: LocalAddress -> LocalAddress -> Bool
$c> :: LocalAddress -> LocalAddress -> Bool
<= :: LocalAddress -> LocalAddress -> Bool
$c<= :: LocalAddress -> LocalAddress -> Bool
< :: LocalAddress -> LocalAddress -> Bool
$c< :: LocalAddress -> LocalAddress -> Bool
compare :: LocalAddress -> LocalAddress -> Ordering
$ccompare :: LocalAddress -> LocalAddress -> Ordering
$cp1Ord :: Eq LocalAddress
Ord)


-- | We support either sockets or named pipes.
--
data AddressFamily addr where

    SocketFamily :: !Socket.Family
                 -> AddressFamily Socket.SockAddr

    LocalFamily  :: AddressFamily LocalAddress

instance Eq (AddressFamily addr) where
    SocketFamily Family
fam0 == :: AddressFamily addr -> AddressFamily addr -> Bool
== SocketFamily Family
fam1 = Family
fam0 Family -> Family -> Bool
forall a. Eq a => a -> a -> Bool
== Family
fam1
    AddressFamily addr
LocalFamily       == AddressFamily addr
LocalFamily       = Bool
True

instance Show (AddressFamily addr) where
    show :: AddressFamily addr -> FilePath
show (SocketFamily Family
fam) = Family -> FilePath
forall a. Show a => a -> FilePath
show Family
fam
    show AddressFamily addr
LocalFamily        = FilePath
"LocalFamily"

-- | Abstract communication interface that can be used by more than
-- 'Socket'.  Snockets are polymorphic over monad which is used, this feature
-- is useful for testing and/or simulations.
--
data Snocket m fd addr
  = Snocket
      { Snocket m fd addr -> fd -> m addr
getLocalAddr  :: fd -> m addr
      , Snocket m fd addr -> fd -> m addr
getRemoteAddr :: fd -> m addr
      , Snocket m fd addr -> addr -> AddressFamily addr
addrFamily    :: addr -> AddressFamily addr
      , Snocket m fd addr -> AddressFamily addr -> m fd
open          :: AddressFamily addr -> m fd
        -- |^ Open a file descriptor: socket='socket', namedPipe='CreateNamedPipe'
      , Snocket m fd addr -> addr -> m fd
openToConnect :: addr -> m fd
        -- |^ A way to create 'fd' to pass to 'connect'.  For named pipes it uses 'CreateFile'
      , Snocket m fd addr -> fd -> addr -> m ()
connect       :: fd -> addr -> m ()
        -- |^ `connect` is only needed for Berkeley sockets, for named pipes this is a no-op.
      , Snocket m fd addr -> fd -> addr -> m ()
bind          :: fd -> addr -> m ()
      , Snocket m fd addr -> fd -> m ()
listen        :: fd -> m ()
      , Snocket m fd addr -> fd -> Accept addr fd
accept        :: fd -> Accept addr fd
      , Snocket m fd addr -> fd -> m ()
close         :: fd -> m ()
      }


--
-- Socket based Snockets
--


socketAddrFamily
    :: Socket.SockAddr
    -> AddressFamily Socket.SockAddr
socketAddrFamily :: SockAddr -> AddressFamily SockAddr
socketAddrFamily (Socket.SockAddrInet  PortNumber
_ HostAddress
_    ) = Family -> AddressFamily SockAddr
SocketFamily Family
Socket.AF_INET
socketAddrFamily (Socket.SockAddrInet6 PortNumber
_ HostAddress
_ HostAddress6
_ HostAddress
_) = Family -> AddressFamily SockAddr
SocketFamily Family
Socket.AF_INET6
socketAddrFamily (Socket.SockAddrUnix FilePath
_       ) = Family -> AddressFamily SockAddr
SocketFamily Family
Socket.AF_UNIX


type SocketSnocket = Snocket IO Socket SockAddr


-- | Create a 'Snocket' for the given 'Socket.Family'. In the 'bind' method set
-- 'Socket.ReuseAddr` and 'Socket.ReusePort'.
--
socketSnocket
  :: IOManager
  -- ^ 'IOManager' interface.  We use it when we create a new socket and when we
  -- accept a connection.
  --
  -- Though it could be used in `open`, but that is going to be used in
  -- a bracket so it's better to keep it simple.
  --
  -> SocketSnocket
socketSnocket :: IOManager -> SocketSnocket
socketSnocket IOManager
ioManager = Snocket :: forall (m :: * -> *) fd addr.
(fd -> m addr)
-> (fd -> m addr)
-> (addr -> AddressFamily addr)
-> (AddressFamily addr -> m fd)
-> (addr -> m fd)
-> (fd -> addr -> m ())
-> (fd -> addr -> m ())
-> (fd -> m ())
-> (fd -> Accept addr fd)
-> (fd -> m ())
-> Snocket m fd addr
Snocket {
      getLocalAddr :: Socket -> IO SockAddr
getLocalAddr   = Socket -> IO SockAddr
Socket.getSocketName
    , getRemoteAddr :: Socket -> IO SockAddr
getRemoteAddr  = Socket -> IO SockAddr
Socket.getPeerName
    , addrFamily :: SockAddr -> AddressFamily SockAddr
addrFamily     = SockAddr -> AddressFamily SockAddr
socketAddrFamily
    , open :: AddressFamily SockAddr -> IO Socket
open           = AddressFamily SockAddr -> IO Socket
openSocket
    , openToConnect :: SockAddr -> IO Socket
openToConnect  = \SockAddr
addr -> AddressFamily SockAddr -> IO Socket
openSocket (SockAddr -> AddressFamily SockAddr
socketAddrFamily SockAddr
addr)
    , connect :: Socket -> SockAddr -> IO ()
connect        = \Socket
s SockAddr
a -> do
#if !defined(mingw32_HOST_OS)
        Socket -> SockAddr -> IO ()
Socket.connect Socket
s SockAddr
a
#else
        Win32.Async.connect s a
#endif
    , bind :: Socket -> SockAddr -> IO ()
bind = \Socket
sd SockAddr
addr -> do
        let SocketFamily Family
fml = SockAddr -> AddressFamily SockAddr
socketAddrFamily SockAddr
addr
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Family
fml Family -> Family -> Bool
forall a. Eq a => a -> a -> Bool
== Family
Socket.AF_INET Bool -> Bool -> Bool
||
              Family
fml Family -> Family -> Bool
forall a. Eq a => a -> a -> Bool
== Family
Socket.AF_INET6) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Socket -> SocketOption -> Int -> IO ()
Socket.setSocketOption Socket
sd SocketOption
Socket.ReuseAddr Int
1
#if !defined(mingw32_HOST_OS)
          -- not supported on Windows 10
          Socket -> SocketOption -> Int -> IO ()
Socket.setSocketOption Socket
sd SocketOption
Socket.ReusePort Int
1
#endif
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Family
fml Family -> Family -> Bool
forall a. Eq a => a -> a -> Bool
== Family
Socket.AF_INET6)
          -- An AF_INET6 socket can be used to talk to both IPv4 and IPv6 end points, and
          -- it is enabled by default on some systems. Disabled here since we run a separate
          -- IPv4 server instance if configured to use IPv4.
          (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Socket -> SocketOption -> Int -> IO ()
Socket.setSocketOption Socket
sd SocketOption
Socket.IPv6Only Int
1

        Socket -> SockAddr -> IO ()
Socket.bind Socket
sd SockAddr
addr
    , listen :: Socket -> IO ()
listen   = \Socket
s -> Socket -> Int -> IO ()
Socket.listen Socket
s Int
8
    , accept :: Socket -> Accept SockAddr Socket
accept   = IOManager -> Socket -> Accept SockAddr Socket
berkeleyAccept IOManager
ioManager
    , close :: Socket -> IO ()
close    = Socket -> IO ()
Socket.close
    }
  where

    openSocket :: AddressFamily SockAddr -> IO Socket
    openSocket :: AddressFamily SockAddr -> IO Socket
openSocket (SocketFamily Family
family_) = do
      Socket
sd <- Family -> SocketType -> ProtocolNumber -> IO Socket
Socket.socket Family
family_ SocketType
Socket.Stream ProtocolNumber
Socket.defaultProtocol
      IOManager -> Either Any Socket -> IO ()
IOManager -> forall hole. hole -> IO ()
associateWithIOManager IOManager
ioManager (Socket -> Either Any Socket
forall a b. b -> Either a b
Right Socket
sd)
        -- open is designed to be used in `bracket`, and thus it's called with
        -- async exceptions masked.  The 'associteWithIOCP' is a blocking
        -- operation and thus it may throw.
        IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
e :: IOException) -> do
          Socket -> IO ()
Socket.close Socket
sd
          IOException -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOException
e
        IO () -> (SomeAsyncException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeAsyncException e
_) -> do
          Socket -> IO ()
Socket.close Socket
sd
          IOException -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOException
e
      Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sd



--
-- NamedPipes based Snocket
--


#if defined(mingw32_HOST_OS)
type HANDLESnocket = Snocket IO Win32.HANDLE LocalAddress

-- | Create a Windows Named Pipe Snocket.
--
namedPipeSnocket
  :: IOManager
  -> FilePath
  -> HANDLESnocket
namedPipeSnocket ioManager path = Snocket {
      getLocalAddr  = \_ -> return localAddress
    , getRemoteAddr = \_ -> return localAddress
    , addrFamily  = \_ -> LocalFamily

    , open = \_addrFamily -> do
        hpipe <- Win32.createNamedPipe
                   path
                   (Win32.pIPE_ACCESS_DUPLEX .|. Win32.fILE_FLAG_OVERLAPPED)
                   (Win32.pIPE_TYPE_BYTE .|. Win32.pIPE_READMODE_BYTE)
                   Win32.pIPE_UNLIMITED_INSTANCES
                   65536   -- outbound pipe size
                   16384   -- inbound pipe size
                   0       -- default timeout
                   Nothing -- default security
        associateWithIOManager ioManager (Left hpipe)
          `catch` \(e :: IOException) -> do
            Win32.closeHandle hpipe
            throwIO e
          `catch` \(SomeAsyncException _) -> do
            Win32.closeHandle hpipe
            throwIO e
        pure hpipe

    -- To connect, simply create a file whose name is the named pipe name.
    , openToConnect  = \(LocalAddress pipeName) -> do
        hpipe <- Win32.connect pipeName
                   (Win32.gENERIC_READ .|. Win32.gENERIC_WRITE )
                   Win32.fILE_SHARE_NONE
                   Nothing
                   Win32.oPEN_EXISTING
                   Win32.fILE_FLAG_OVERLAPPED
                   Nothing
        associateWithIOManager ioManager (Left hpipe)
          `catch` \(e :: IOException) -> do
            Win32.closeHandle hpipe
            throwIO e
          `catch` \(SomeAsyncException _) -> do
            Win32.closeHandle hpipe
            throwIO e
        return hpipe
    , connect  = \_ _ -> pure ()

    -- Bind and listen are no-op.
    , bind     = \_ _ -> pure ()
    , listen   = \_ -> pure ()

    , accept   = \hpipe -> Accept $ do
          Win32.Async.connectNamedPipe hpipe
          return (hpipe, localAddress, acceptNext)

    , close    = Win32.closeHandle
    }
  where
    localAddress :: LocalAddress
    localAddress = LocalAddress path

    acceptNext :: Accept LocalAddress Win32.HANDLE
    acceptNext = Accept $ do
      hpipe <- Win32.createNamedPipe
                 path
                 (Win32.pIPE_ACCESS_DUPLEX .|. Win32.fILE_FLAG_OVERLAPPED)
                 (Win32.pIPE_TYPE_BYTE .|. Win32.pIPE_READMODE_BYTE)
                 Win32.pIPE_UNLIMITED_INSTANCES
                 65536   -- outbound pipe size
                 16384   -- inbound pipe size
                 0       -- default timeout
                 Nothing -- default security
              `catch` \(e :: IOException) -> do
                 putStrLn $ "accept: " ++ show e
                 throwIO e
      associateWithIOManager ioManager (Left hpipe)
      Win32.Async.connectNamedPipe hpipe
      return (hpipe, localAddress, acceptNext)
#endif


--
-- Windows/POSIX type aliases
--

localSnocket :: IOManager -> FilePath -> LocalSnocket
localFDToHandle :: LocalFD -> IO IO.Handle

-- | System dependent LocalSnocket type
#if defined(mingw32_HOST_OS)
type LocalSnocket = HANDLESnocket
type LocalFD      = Win32.HANDLE

localSnocket = namedPipeSnocket
localFDToHandle = hANDLEToHandle
#else
type LocalSnocket = Snocket IO Socket LocalAddress
type LocalFD      = Socket

localSnocket :: IOManager -> FilePath -> LocalSnocket
localSnocket IOManager
ioManager FilePath
_ = Snocket :: forall (m :: * -> *) fd addr.
(fd -> m addr)
-> (fd -> m addr)
-> (addr -> AddressFamily addr)
-> (AddressFamily addr -> m fd)
-> (addr -> m fd)
-> (fd -> addr -> m ())
-> (fd -> addr -> m ())
-> (fd -> m ())
-> (fd -> Accept addr fd)
-> (fd -> m ())
-> Snocket m fd addr
Snocket {
      getLocalAddr :: Socket -> IO LocalAddress
getLocalAddr  = (SockAddr -> LocalAddress) -> IO SockAddr -> IO LocalAddress
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SockAddr -> LocalAddress
toLocalAddress (IO SockAddr -> IO LocalAddress)
-> (Socket -> IO SockAddr) -> Socket -> IO LocalAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> IO SockAddr
Socket.getSocketName
    , getRemoteAddr :: Socket -> IO LocalAddress
getRemoteAddr = (SockAddr -> LocalAddress) -> IO SockAddr -> IO LocalAddress
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SockAddr -> LocalAddress
toLocalAddress (IO SockAddr -> IO LocalAddress)
-> (Socket -> IO SockAddr) -> Socket -> IO LocalAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> IO SockAddr
Socket.getPeerName
    , addrFamily :: LocalAddress -> AddressFamily LocalAddress
addrFamily    = AddressFamily LocalAddress
-> LocalAddress -> AddressFamily LocalAddress
forall a b. a -> b -> a
const AddressFamily LocalAddress
LocalFamily
    , connect :: Socket -> LocalAddress -> IO ()
connect       = \Socket
s LocalAddress
addr -> do
        Socket -> SockAddr -> IO ()
Socket.connect Socket
s (LocalAddress -> SockAddr
fromLocalAddress LocalAddress
addr)
    , bind :: Socket -> LocalAddress -> IO ()
bind          = \Socket
fd LocalAddress
addr -> Socket -> SockAddr -> IO ()
Socket.bind Socket
fd (LocalAddress -> SockAddr
fromLocalAddress LocalAddress
addr)
    , listen :: Socket -> IO ()
listen        = (Socket -> Int -> IO ()) -> Int -> Socket -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Socket -> Int -> IO ()
Socket.listen Int
1
    , accept :: Socket -> Accept LocalAddress Socket
accept        = (SockAddr -> LocalAddress)
-> Accept SockAddr Socket -> Accept LocalAddress Socket
forall addr addr' fd.
(addr -> addr') -> Accept addr fd -> Accept addr' fd
fmapAccept SockAddr -> LocalAddress
toLocalAddress (Accept SockAddr Socket -> Accept LocalAddress Socket)
-> (Socket -> Accept SockAddr Socket)
-> Socket
-> Accept LocalAddress Socket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IOManager -> Socket -> Accept SockAddr Socket
berkeleyAccept IOManager
ioManager)
    , open :: AddressFamily LocalAddress -> IO Socket
open          = AddressFamily LocalAddress -> IO Socket
openSocket
    , openToConnect :: LocalAddress -> IO Socket
openToConnect = \LocalAddress
_addr -> AddressFamily LocalAddress -> IO Socket
openSocket AddressFamily LocalAddress
LocalFamily
    , close :: Socket -> IO ()
close         = Socket -> IO ()
Socket.close
    }
  where
    toLocalAddress :: SockAddr -> LocalAddress
    toLocalAddress :: SockAddr -> LocalAddress
toLocalAddress (SockAddrUnix FilePath
path) = FilePath -> LocalAddress
LocalAddress FilePath
path
    toLocalAddress SockAddr
_                   = FilePath -> LocalAddress
forall a. HasCallStack => FilePath -> a
error FilePath
"localSnocket.toLocalAddr: impossible happend"

    fromLocalAddress :: LocalAddress -> SockAddr
    fromLocalAddress :: LocalAddress -> SockAddr
fromLocalAddress = FilePath -> SockAddr
SockAddrUnix (FilePath -> SockAddr)
-> (LocalAddress -> FilePath) -> LocalAddress -> SockAddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalAddress -> FilePath
getFilePath

    openSocket :: AddressFamily LocalAddress -> IO Socket
    openSocket :: AddressFamily LocalAddress -> IO Socket
openSocket AddressFamily LocalAddress
LocalFamily = do
      Socket
sd <- Family -> SocketType -> ProtocolNumber -> IO Socket
Socket.socket Family
Socket.AF_UNIX SocketType
Socket.Stream ProtocolNumber
Socket.defaultProtocol
      IOManager -> Either Any Socket -> IO ()
IOManager -> forall hole. hole -> IO ()
associateWithIOManager IOManager
ioManager (Socket -> Either Any Socket
forall a b. b -> Either a b
Right Socket
sd)
        -- open is designed to be used in `bracket`, and thus it's called with
        -- async exceptions masked.  The 'associteWithIOManager' is a blocking
        -- operation and thus it may throw.
        IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
e :: IOException) -> do
          Socket -> IO ()
Socket.close Socket
sd
          IOException -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOException
e
        IO () -> (SomeAsyncException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeAsyncException e
_) -> do
          Socket -> IO ()
Socket.close Socket
sd
          IOException -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOException
e
      Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sd

localFDToHandle :: Socket -> IO Handle
localFDToHandle = (Socket -> IOMode -> IO Handle) -> IOMode -> Socket -> IO Handle
forall a b c. (a -> b -> c) -> b -> a -> c
flip Socket -> IOMode -> IO Handle
Socket.socketToHandle IOMode
IO.ReadWriteMode
#endif

localAddressFromPath :: FilePath -> LocalAddress
localAddressFromPath :: FilePath -> LocalAddress
localAddressFromPath = FilePath -> LocalAddress
LocalAddress