{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE DerivingVia         #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Ouroboros.Network.Snocket
  ( -- * Snocket Interface
    Accept (..)
  , AddressFamily (..)
  , Snocket (..)
    -- ** Socket based Snocktes
  , SocketSnocket
  , socketSnocket
    -- ** Local Snockets
    -- Using unix sockets (posix) or named pipes (windows)
    --
  , LocalSnocket
  , localSnocket
  , LocalSocket (..)
  , LocalAddress (..)
  , localAddressFromPath

  , FileDescriptor
  , socketFileDescriptor
  , localSocketFileDescriptor
  ) where

import           Control.Exception
import           Control.Monad (when)
import           Control.Monad.Class.MonadTime (DiffTime)
import           Control.Tracer (Tracer)
import           Data.Bifunctor (Bifunctor (..))
import           Data.Hashable
import           GHC.Generics (Generic)
import           Quiet (Quiet (..))
#if !defined(mingw32_HOST_OS)
import           Network.Socket ( Family (AF_UNIX) )
#endif
import           Network.Socket ( Socket
                                , SockAddr (..)
                                )
import qualified Network.Socket as Socket
#if defined(mingw32_HOST_OS)
import           Data.Bits
import           Foreign.Ptr (IntPtr (..), ptrToIntPtr)
import qualified System.Win32            as Win32
import qualified System.Win32.NamedPipes as Win32
import qualified System.Win32.Async      as Win32.Async

import           Network.Mux.Bearer.NamedPipe (namedPipeAsBearer)
#endif

import           Network.Mux.Types (MuxBearer)
import           Network.Mux.Trace (MuxTrace)
import qualified Network.Mux.Bearer.Socket as Mx

import           Ouroboros.Network.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 m fd addr = Accept
  { Accept m fd addr -> m (fd, addr, Accept m fd addr)
runAccept :: m (fd, addr, Accept m fd addr)
  }

instance Functor m => Bifunctor (Accept m) where
    bimap :: (a -> b) -> (c -> d) -> Accept m a c -> Accept m b d
bimap a -> b
f c -> d
g Accept m a c
ac = m (b, d, Accept m b d) -> Accept m b d
forall (m :: * -> *) fd addr.
m (fd, addr, Accept m fd addr) -> Accept m fd addr
Accept (m (b, d, Accept m b d) -> Accept m b d)
-> m (b, d, Accept m b d) -> Accept m b d
forall a b. (a -> b) -> a -> b
$ (a, c, Accept m a c) -> (b, d, Accept m b d)
h ((a, c, Accept m a c) -> (b, d, Accept m b d))
-> m (a, c, Accept m a c) -> m (b, d, Accept m b d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Accept m a c -> m (a, c, Accept m a c)
forall (m :: * -> *) fd addr.
Accept m fd addr -> m (fd, addr, Accept m fd addr)
runAccept Accept m a c
ac
      where
        h :: (a, c, Accept m a c) -> (b, d, Accept m b d)
h (a
fd, c
addr, Accept m a c
next) = (a -> b
f a
fd, c -> d
g c
addr, (a -> b) -> (c -> d) -> Accept m a c -> Accept m b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f c -> d
g Accept m a c
next)


-- | BSD accept loop.
--
berkeleyAccept :: IOManager
               -> Socket
               -> Accept IO Socket SockAddr
berkeleyAccept :: IOManager -> Socket -> Accept IO Socket SockAddr
berkeleyAccept IOManager
ioManager Socket
sock = Accept IO Socket SockAddr
go
    where
      go :: Accept IO Socket SockAddr
go = IO (Socket, SockAddr, Accept IO Socket SockAddr)
-> Accept IO Socket SockAddr
forall (m :: * -> *) fd addr.
m (fd, addr, Accept m fd addr) -> Accept m fd addr
Accept (IO (Socket, SockAddr, Accept IO Socket SockAddr)
 -> Accept IO Socket SockAddr)
-> IO (Socket, SockAddr, Accept IO Socket SockAddr)
-> Accept IO Socket SockAddr
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 IO Socket SockAddr)
-> IO (Socket, SockAddr, Accept IO Socket SockAddr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
sock', SockAddr
addr', Accept IO Socket SockAddr
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 (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, (forall x. LocalAddress -> Rep LocalAddress x)
-> (forall x. Rep LocalAddress x -> LocalAddress)
-> Generic LocalAddress
forall x. Rep LocalAddress x -> LocalAddress
forall x. LocalAddress -> Rep LocalAddress x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LocalAddress x -> LocalAddress
$cfrom :: forall x. LocalAddress -> Rep LocalAddress x
Generic)
  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 via Quiet LocalAddress

instance Hashable LocalAddress where
    hashWithSalt :: Int -> LocalAddress -> Int
hashWithSalt Int
s (LocalAddress FilePath
path) = Int -> FilePath -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s FilePath
path

-- | 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

  -- | Open a file descriptor  (socket / namedPipe).  For named pipes this is
  -- using 'CreateNamedPipe' syscall, for Berkeley sockets 'socket' is used..
  --
  , Snocket m fd addr -> AddressFamily addr -> m fd
open          :: AddressFamily addr -> m fd

    -- | A way to create 'fd' to pass to 'connect'.  For named pipes it will
    -- use 'CreateFile' syscall.  For Berkeley sockets this the same as 'open'.
    --
    -- For named pipes we need full 'addr' rather than just address family as
    -- it is for sockets.
    --
  , Snocket m fd addr -> addr -> m fd
openToConnect :: addr ->  m fd

    -- | `connect` is only needed for Berkeley sockets, for named pipes this is
    -- no-op.
    --
  , Snocket m fd addr -> fd -> addr -> m ()
connect       :: fd -> addr -> m ()
  , 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 m fd addr
accept        :: fd -> Accept m fd addr

  , Snocket m fd addr -> fd -> m ()
close         :: fd -> m ()

  , Snocket m fd addr
-> DiffTime -> Tracer m MuxTrace -> fd -> MuxBearer m
toBearer      ::  DiffTime -> Tracer m MuxTrace -> fd -> MuxBearer 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 m fd addr)
-> (fd -> m ())
-> (DiffTime -> Tracer m MuxTrace -> fd -> MuxBearer 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
          Socket -> SocketOption -> Int -> IO ()
Socket.setSocketOption Socket
sd SocketOption
Socket.NoDelay Int
1
        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 IO Socket SockAddr
accept   = IOManager -> Socket -> Accept IO Socket SockAddr
berkeleyAccept IOManager
ioManager
    , close :: Socket -> IO ()
close    = Socket -> IO ()
Socket.close
    , toBearer :: DiffTime -> Tracer IO MuxTrace -> Socket -> MuxBearer IO
toBearer = DiffTime -> Tracer IO MuxTrace -> Socket -> MuxBearer IO
Mx.socketAsMuxBearer
    }
  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



--
-- LocalSnockets either based on unix sockets or named pipes.
--

#if defined(mingw32_HOST_OS)
type LocalHandle = Win32.HANDLE
#else
type LocalHandle = Socket
#endif

-- | System dependent LocalSnocket type
newtype LocalSocket  = LocalSocket { LocalSocket -> Socket
getLocalHandle :: LocalHandle }
    deriving (LocalSocket -> LocalSocket -> Bool
(LocalSocket -> LocalSocket -> Bool)
-> (LocalSocket -> LocalSocket -> Bool) -> Eq LocalSocket
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LocalSocket -> LocalSocket -> Bool
$c/= :: LocalSocket -> LocalSocket -> Bool
== :: LocalSocket -> LocalSocket -> Bool
$c== :: LocalSocket -> LocalSocket -> Bool
Eq, (forall x. LocalSocket -> Rep LocalSocket x)
-> (forall x. Rep LocalSocket x -> LocalSocket)
-> Generic LocalSocket
forall x. Rep LocalSocket x -> LocalSocket
forall x. LocalSocket -> Rep LocalSocket x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LocalSocket x -> LocalSocket
$cfrom :: forall x. LocalSocket -> Rep LocalSocket x
Generic)
    deriving Int -> LocalSocket -> ShowS
[LocalSocket] -> ShowS
LocalSocket -> FilePath
(Int -> LocalSocket -> ShowS)
-> (LocalSocket -> FilePath)
-> ([LocalSocket] -> ShowS)
-> Show LocalSocket
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [LocalSocket] -> ShowS
$cshowList :: [LocalSocket] -> ShowS
show :: LocalSocket -> FilePath
$cshow :: LocalSocket -> FilePath
showsPrec :: Int -> LocalSocket -> ShowS
$cshowsPrec :: Int -> LocalSocket -> ShowS
Show via Quiet LocalSocket

-- | System dependent LocalSnocket
type    LocalSnocket = Snocket IO LocalSocket LocalAddress

localSnocket :: IOManager -> FilePath -> LocalSnocket
#if defined(mingw32_HOST_OS)
localSnocket 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 (LocalSocket 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 (LocalSocket hpipe)
    , connect  = \_ _ -> pure ()

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

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

    , close    = Win32.closeHandle . getLocalHandle

    , toBearer = \_sduTimeout tr -> namedPipeAsBearer tr . getLocalHandle
    }
  where
    localAddress :: LocalAddress
    localAddress = LocalAddress path

    acceptNext :: Accept IO LocalSocket LocalAddress
    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
      associateWithIOManager ioManager (Left hpipe)
      Win32.Async.connectNamedPipe hpipe
      return (LocalSocket hpipe, localAddress, acceptNext)

-- local snocket on unix
#else

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 m fd addr)
-> (fd -> m ())
-> (DiffTime -> Tracer m MuxTrace -> fd -> MuxBearer m)
-> Snocket m fd addr
Snocket {
        getLocalAddr :: LocalSocket -> 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)
-> (LocalSocket -> IO SockAddr) -> LocalSocket -> IO LocalAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> IO SockAddr
Socket.getSocketName (Socket -> IO SockAddr)
-> (LocalSocket -> Socket) -> LocalSocket -> IO SockAddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalSocket -> Socket
getLocalHandle
      , getRemoteAddr :: LocalSocket -> 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)
-> (LocalSocket -> IO SockAddr) -> LocalSocket -> IO LocalAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> IO SockAddr
Socket.getPeerName (Socket -> IO SockAddr)
-> (LocalSocket -> Socket) -> LocalSocket -> IO SockAddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalSocket -> Socket
getLocalHandle
      , addrFamily :: LocalAddress -> AddressFamily LocalAddress
addrFamily    = AddressFamily LocalAddress
-> LocalAddress -> AddressFamily LocalAddress
forall a b. a -> b -> a
const AddressFamily LocalAddress
LocalFamily
      , connect :: LocalSocket -> LocalAddress -> IO ()
connect       = \(LocalSocket Socket
s) LocalAddress
addr ->
          Socket -> SockAddr -> IO ()
Socket.connect Socket
s (LocalAddress -> SockAddr
fromLocalAddress LocalAddress
addr)
      , bind :: LocalSocket -> LocalAddress -> IO ()
bind          = \(LocalSocket Socket
fd) LocalAddress
addr -> Socket -> SockAddr -> IO ()
Socket.bind Socket
fd (LocalAddress -> SockAddr
fromLocalAddress LocalAddress
addr)
      , listen :: LocalSocket -> 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 (Socket -> IO ())
-> (LocalSocket -> Socket) -> LocalSocket -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalSocket -> Socket
getLocalHandle
      , accept :: LocalSocket -> Accept IO LocalSocket LocalAddress
accept        = (Socket -> LocalSocket)
-> (SockAddr -> LocalAddress)
-> Accept IO Socket SockAddr
-> Accept IO LocalSocket LocalAddress
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Socket -> LocalSocket
LocalSocket SockAddr -> LocalAddress
toLocalAddress
                      (Accept IO Socket SockAddr -> Accept IO LocalSocket LocalAddress)
-> (LocalSocket -> Accept IO Socket SockAddr)
-> LocalSocket
-> Accept IO LocalSocket LocalAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOManager -> Socket -> Accept IO Socket SockAddr
berkeleyAccept IOManager
ioManager
                      (Socket -> Accept IO Socket SockAddr)
-> (LocalSocket -> Socket)
-> LocalSocket
-> Accept IO Socket SockAddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalSocket -> Socket
getLocalHandle
      , open :: AddressFamily LocalAddress -> IO LocalSocket
open          = AddressFamily LocalAddress -> IO LocalSocket
openSocket
      , openToConnect :: LocalAddress -> IO LocalSocket
openToConnect = \LocalAddress
_addr -> AddressFamily LocalAddress -> IO LocalSocket
openSocket AddressFamily LocalAddress
LocalFamily
      , close :: LocalSocket -> IO ()
close         = Socket -> IO ()
Socket.close (Socket -> IO ())
-> (LocalSocket -> Socket) -> LocalSocket -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalSocket -> Socket
getLocalHandle
      , toBearer :: DiffTime -> Tracer IO MuxTrace -> LocalSocket -> MuxBearer IO
toBearer      = \DiffTime
df Tracer IO MuxTrace
tr (LocalSocket Socket
sd) -> DiffTime -> Tracer IO MuxTrace -> Socket -> MuxBearer IO
Mx.socketAsMuxBearer DiffTime
df Tracer IO MuxTrace
tr Socket
sd
      }
  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 LocalSocket
    openSocket :: AddressFamily LocalAddress -> IO LocalSocket
openSocket AddressFamily LocalAddress
LocalFamily = do
      Socket
sd <- Family -> SocketType -> ProtocolNumber -> IO Socket
Socket.socket Family
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
      LocalSocket -> IO LocalSocket
forall (m :: * -> *) a. Monad m => a -> m a
return (Socket -> LocalSocket
LocalSocket Socket
sd)
#endif

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

-- | Socket file descriptor.
--
newtype FileDescriptor = FileDescriptor { FileDescriptor -> Int
getFileDescriptor :: Int }
  deriving (forall x. FileDescriptor -> Rep FileDescriptor x)
-> (forall x. Rep FileDescriptor x -> FileDescriptor)
-> Generic FileDescriptor
forall x. Rep FileDescriptor x -> FileDescriptor
forall x. FileDescriptor -> Rep FileDescriptor x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FileDescriptor x -> FileDescriptor
$cfrom :: forall x. FileDescriptor -> Rep FileDescriptor x
Generic
  deriving Int -> FileDescriptor -> ShowS
[FileDescriptor] -> ShowS
FileDescriptor -> FilePath
(Int -> FileDescriptor -> ShowS)
-> (FileDescriptor -> FilePath)
-> ([FileDescriptor] -> ShowS)
-> Show FileDescriptor
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [FileDescriptor] -> ShowS
$cshowList :: [FileDescriptor] -> ShowS
show :: FileDescriptor -> FilePath
$cshow :: FileDescriptor -> FilePath
showsPrec :: Int -> FileDescriptor -> ShowS
$cshowsPrec :: Int -> FileDescriptor -> ShowS
Show via Quiet FileDescriptor

-- | We use 'unsafeFdSocket' but 'FileDescriptor' constructor is not exposed.
-- This forbids any usage of 'FileDescriptor' (at least in a straightforward
-- way) using any low level functions which operate on file descriptors.
--
socketFileDescriptor :: Socket -> IO FileDescriptor
socketFileDescriptor :: Socket -> IO FileDescriptor
socketFileDescriptor = (ProtocolNumber -> FileDescriptor)
-> IO ProtocolNumber -> IO FileDescriptor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> FileDescriptor
FileDescriptor (Int -> FileDescriptor)
-> (ProtocolNumber -> Int) -> ProtocolNumber -> FileDescriptor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (IO ProtocolNumber -> IO FileDescriptor)
-> (Socket -> IO ProtocolNumber) -> Socket -> IO FileDescriptor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> IO ProtocolNumber
Socket.unsafeFdSocket

localSocketFileDescriptor :: LocalSocket -> IO FileDescriptor
#if defined(mingw32_HOST_OS)
localSocketFileDescriptor =
  \(LocalSocket fd) -> case ptrToIntPtr fd of
    IntPtr i -> return (FileDescriptor i)
#else
localSocketFileDescriptor :: LocalSocket -> IO FileDescriptor
localSocketFileDescriptor = Socket -> IO FileDescriptor
socketFileDescriptor (Socket -> IO FileDescriptor)
-> (LocalSocket -> Socket) -> LocalSocket -> IO FileDescriptor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalSocket -> Socket
getLocalHandle
#endif