{-# LINE 1 "System\\Win32\\NamedPipes.hsc" #-}





{-# LANGUAGE CPP                #-}
{-# LANGUAGE BangPatterns       #-}
{-# LANGUAGE MultiWayIf         #-}
{-# LANGUAGE NumericUnderscores #-}

-- | For full details on the Windows named pipes API see

-- <https://docs.microsoft.com/en-us/windows/desktop/ipc/named-pipes>

--

module System.Win32.NamedPipes (

    -- * Named pipe server APIs

    createNamedPipe,
    pIPE_UNLIMITED_INSTANCES,

    -- ** Parameter types

    LPSECURITY_ATTRIBUTES,
    OpenMode,
    pIPE_ACCESS_DUPLEX,
    pIPE_ACCESS_INBOUND,
    pIPE_ACCESS_OUTBOUND,
    fILE_FLAG_OVERLAPPED,
    PipeMode,
    pIPE_TYPE_BYTE,
    pIPE_TYPE_MESSAGE,
    pIPE_READMODE_BYTE,
    pIPE_READMODE_MESSAGE,
    pIPE_WAIT,
    pIPE_NOWAIT,
    pIPE_ACCEPT_REMOTE_CLIENTS,
    pIPE_REJECT_REMOTE_CLIENTS,

    -- * Named pipe client APIs

    -- ** connect to a named pipe

    connect,

    -- ** waiting for named pipe instances

    waitNamedPipe,

    TimeOut,
    nMPWAIT_USE_DEFAULT_WAIT,
    nMPWAIT_WAIT_FOREVER,
  ) where


import Control.Exception
import Control.Monad (when)
import Foreign.C.String (withCString)

import System.Win32.Types hiding (try)
import System.Win32.File

-- | The named pipe open mode.

--

-- This must specify one of:

--

-- * 'pIPE_ACCESS_DUPLEX'

-- * 'pIPE_ACCESS_INBOUND'

-- * 'pIPE_ACCESS_OUTBOUND'

--

-- It may also specify:

--

-- * 'fILE_FLAG_WRITE_THROUGH'

-- * 'fILE_FLAG_OVERLAPPED'

--

-- It may also specify any combination of:

--

-- * 'wRITE_DAC'

-- * 'wRITE_OWNER'

-- * 'aCCESS_SYSTEM_SECURITY'

--

type OpenMode = UINT

pIPE_ACCESS_DUPLEX             :: OpenMode
pIPE_ACCESS_DUPLEX :: ErrCode
pIPE_ACCESS_DUPLEX             =  ErrCode
3
pIPE_ACCESS_INBOUND            :: OpenMode
pIPE_ACCESS_INBOUND :: ErrCode
pIPE_ACCESS_INBOUND            =  ErrCode
1
pIPE_ACCESS_OUTBOUND           :: OpenMode
pIPE_ACCESS_OUTBOUND :: ErrCode
pIPE_ACCESS_OUTBOUND           =  ErrCode
2

{-# LINE 83 "System\\Win32\\NamedPipes.hsc" #-}

-- | The pipe mode.

--

-- One of the following type modes can be specified. The same type mode must be

-- specified for each instance of the pipe.

--

-- * 'pIPE_TYPE_BYTE'

-- * 'pIPE_TYPE_MESSAGE'

--

-- One of the following read modes can be specified. Different instances of the

-- same pipe can specify different read modes.

--

-- * 'pIPE_READMODE_BYTE'

-- * 'pIPE_READMODE_MESSAGE'

--

-- One of the following wait modes can be specified. Different instances of the

-- same pipe can specify different wait modes.

--

-- * 'pIPE_WAIT'

-- * 'pIPE_NOWAIT'

--

-- One of the following remote-client modes can be specified.  Different

-- instances of the same pipe can specify different remote-client modes.

--

-- * 'pIPE_ACCEPT_REMOTE_CLIENT'

-- * 'pIPE_REJECT_REMOTE_CLIENT'

--

type PipeMode = UINT

pIPE_TYPE_BYTE                 :: PipeMode
pIPE_TYPE_BYTE :: ErrCode
pIPE_TYPE_BYTE                 =  ErrCode
0
pIPE_TYPE_MESSAGE              :: PipeMode
pIPE_TYPE_MESSAGE :: ErrCode
pIPE_TYPE_MESSAGE              =  ErrCode
4
pIPE_READMODE_BYTE             :: PipeMode
pIPE_READMODE_BYTE :: ErrCode
pIPE_READMODE_BYTE             =  ErrCode
0
pIPE_READMODE_MESSAGE          :: PipeMode
pIPE_READMODE_MESSAGE :: ErrCode
pIPE_READMODE_MESSAGE          =  ErrCode
2
pIPE_WAIT                      :: PipeMode
pIPE_WAIT :: ErrCode
pIPE_WAIT                      =  ErrCode
0
pIPE_NOWAIT                    :: PipeMode
pIPE_NOWAIT :: ErrCode
pIPE_NOWAIT                    =  ErrCode
1
pIPE_ACCEPT_REMOTE_CLIENTS     :: PipeMode
pIPE_ACCEPT_REMOTE_CLIENTS :: ErrCode
pIPE_ACCEPT_REMOTE_CLIENTS     =  ErrCode
0
pIPE_REJECT_REMOTE_CLIENTS     :: PipeMode
pIPE_REJECT_REMOTE_CLIENTS :: ErrCode
pIPE_REJECT_REMOTE_CLIENTS     =  ErrCode
8

{-# LINE 122 "System\\Win32\\NamedPipes.hsc" #-}

-- | If the 'createNamedPipe' @nMaxInstances@ parameter is

-- 'pIPE_UNLIMITED_INSTANCES', the number of pipe instances that can be created

-- is limited only by the availability of system resources.

pIPE_UNLIMITED_INSTANCES :: DWORD
pIPE_UNLIMITED_INSTANCES = 255
{-# LINE 128 "System\\Win32\\NamedPipes.hsc" #-}

-- | Creates an instance of a named pipe and returns a handle for subsequent

-- pipe operations. A named pipe server process uses this function either to

-- create the first instance of a specific named pipe and establish its basic

-- attributes or to create a new instance of an existing named pipe.

--

-- For full details see

-- <https://docs.microsoft.com/en-us/windows/desktop/api/winbase/nf-winbase-createnamedpipea>

--

-- To create a named pipe which can be associate with IO completion port on

-- needs to pass 'fILE_FLAG_OVERLAPPED' to 'OpenMode' argument,

-- e.g.

--

-- >  Win32.createNamedPipe pipeName

-- >                        (pIPE_ACCESS_DUPLEX .|. fILE_FLAG_OVERLAPPED)

-- >                        (pIPE_TYPE_BYTE .|. pIPE_READMODE_BYTE)

-- >                        pIPE_UNLIMITED_INSTANCES

-- >                        512

-- >                        512

-- >                        0

-- >                        NothinROR

--

--

createNamedPipe :: String   -- ^ A unique pipe name of the form @\\.\pipe\{pipename}@

                            -- The `pipename` part of the name can include any

                            -- character other than a backslash, including

                            -- numbers and special characters. The entire pipe

                            -- name string can be up to 256 characters long.

                            -- Pipe names are not case sensitive.

                -> OpenMode
                -> PipeMode
                -> DWORD    -- ^ nMaxInstances

                -> DWORD    -- ^ nOutBufferSize

                -> DWORD    -- ^ nInBufferSize

                -> DWORD    -- ^ nDefaultTimeOut

                -> Maybe LPSECURITY_ATTRIBUTES
                -> IO HANDLE
createNamedPipe :: String
-> ErrCode
-> ErrCode
-> ErrCode
-> ErrCode
-> ErrCode
-> ErrCode
-> Maybe LPSECURITY_ATTRIBUTES
-> IO HANDLE
createNamedPipe String
name ErrCode
openMode ErrCode
pipeMode
                ErrCode
nMaxInstances ErrCode
nOutBufferSize ErrCode
nInBufferSize
                ErrCode
nDefaultTimeOut Maybe LPSECURITY_ATTRIBUTES
mb_attr =
  String -> (LPTSTR -> IO HANDLE) -> IO HANDLE
forall a. String -> (LPTSTR -> IO a) -> IO a
withTString String
name ((LPTSTR -> IO HANDLE) -> IO HANDLE)
-> (LPTSTR -> IO HANDLE) -> IO HANDLE
forall a b. (a -> b) -> a -> b
$ \ LPTSTR
c_name ->
    (HANDLE -> Bool) -> String -> IO HANDLE -> IO HANDLE
forall a. (a -> Bool) -> String -> IO a -> IO a
failIf (HANDLE -> HANDLE -> Bool
forall a. Eq a => a -> a -> Bool
==HANDLE
iNVALID_HANDLE_VALUE) (String
"CreateNamedPipe ('" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"')") (IO HANDLE -> IO HANDLE) -> IO HANDLE -> IO HANDLE
forall a b. (a -> b) -> a -> b
$
      LPTSTR
-> ErrCode
-> ErrCode
-> ErrCode
-> ErrCode
-> ErrCode
-> ErrCode
-> LPSECURITY_ATTRIBUTES
-> IO HANDLE
c_CreateNamedPipe LPTSTR
c_name ErrCode
openMode ErrCode
pipeMode
                        ErrCode
nMaxInstances ErrCode
nOutBufferSize ErrCode
nInBufferSize
                        ErrCode
nDefaultTimeOut (Maybe LPSECURITY_ATTRIBUTES -> LPSECURITY_ATTRIBUTES
forall a. Maybe (Ptr a) -> Ptr a
maybePtr Maybe LPSECURITY_ATTRIBUTES
mb_attr)

foreign import ccall unsafe "windows.h CreateNamedPipeW"
  c_CreateNamedPipe :: LPCTSTR
                    -> DWORD
                    -> DWORD
                    -> DWORD
                    -> DWORD
                    -> DWORD
                    -> DWORD
                    -> LPSECURITY_ATTRIBUTES
                    -> IO HANDLE


-- | Timeout in milliseconds.

--

-- * 'nMPWAIT_USE_DEFAULT_WAIT' indicates that the timeout value passed to

--   'createNamedPipe' should be used.

-- * 'nMPWAIT_WAIT_FOREVER' - 'waitNamedPipe' will block forever, until a named

--   pipe instance is available.

--

type TimeOut = DWORD
nMPWAIT_USE_DEFAULT_WAIT  :: TimeOut
nMPWAIT_USE_DEFAULT_WAIT :: ErrCode
nMPWAIT_USE_DEFAULT_WAIT  =  ErrCode
0
nMPWAIT_WAIT_FOREVER      :: TimeOut
nMPWAIT_WAIT_FOREVER :: ErrCode
nMPWAIT_WAIT_FOREVER      =  ErrCode
4294967295

{-# LINE 198 "System\\Win32\\NamedPipes.hsc" #-}


-- | Wait until a named pipe instance is available.  If there is no instance at

-- hand before the timeout, it will error with 'ERROR_SEM_TIMEOUT', i.e.

-- @invalid argument (The semaphore timeout period has expired)@

--

-- It returns 'True' if there is an available instance, subsequent 'createFile'

-- might still fail, if another thread will take turn and connect before, or if

-- the other end shuts down the name pipe.

--

-- It returns 'False' if timeout fired.

--

waitNamedPipe :: String  -- ^ pipe name

              -> TimeOut -- ^ nTimeOut

              -> IO Bool
waitNamedPipe :: String -> ErrCode -> IO Bool
waitNamedPipe String
name ErrCode
timeout =
    String -> (CString -> IO Bool) -> IO Bool
forall a. String -> (CString -> IO a) -> IO a
withCString String
name ((CString -> IO Bool) -> IO Bool)
-> (CString -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \ CString
c_name -> do
      Bool
r <- CString -> ErrCode -> IO Bool
c_WaitNamedPipe CString
c_name ErrCode
timeout
      ErrCode
e <- IO ErrCode
getLastError
      if | Bool
r                      -> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
r
         | ErrCode
e ErrCode -> ErrCode -> Bool
forall a. Eq a => a -> a -> Bool
== ErrCode
eRROR_SEM_TIMEOUT -> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
         | Bool
otherwise              -> String -> ErrCode -> IO Bool
forall a. String -> ErrCode -> IO a
failWith String
"waitNamedPipe" ErrCode
e


-- 'c_WaitNamedPipe' is a blocking call, hence the _safe_ import.

foreign import ccall safe "windows.h WaitNamedPipeA"
  c_WaitNamedPipe :: LPCSTR -- lpNamedPipeName

                  -> DWORD  -- nTimeOut

                  -> IO BOOL

-- | A reliable connect call, as designed in

-- <https://docs.microsoft.com/en-us/windows/win32/ipc/named-pipe-client>

--

-- The arguments are passed directly to 'createFile'.

--

-- Note we pick the more familiar posix naming convention, do not confuse this

-- function with 'connectNamedPipe' (which corresponds to posix 'accept')

--

connect :: String                      -- ^ file name

        -> AccessMode                  -- ^ dwDesiredAccess

        -> ShareMode                   -- ^ dwSharedMode

        -> Maybe LPSECURITY_ATTRIBUTES -- ^ lpSecurityAttributes

        -> CreateMode                  -- ^ dwCreationDisposition

        -> FileAttributeOrFlag         -- ^ dwFlagsAndAttributes

        -> Maybe HANDLE                -- ^ hTemplateFile

        -> IO HANDLE
connect :: String
-> ErrCode
-> ErrCode
-> Maybe LPSECURITY_ATTRIBUTES
-> ErrCode
-> ErrCode
-> Maybe HANDLE
-> IO HANDLE
connect String
fileName ErrCode
dwDesiredAccess ErrCode
dwSharedMode Maybe LPSECURITY_ATTRIBUTES
lpSecurityAttributes ErrCode
dwCreationDisposition ErrCode
dwFlagsAndAttributes Maybe HANDLE
hTemplateFile = IO HANDLE
connectLoop
  where
    connectLoop :: IO HANDLE
connectLoop = do
      -- `createFile` checks for `INVALID_HANDLE_VALUE` and retries if this is

      -- caused by `ERROR_SHARING_VIOLATION`.

      Either IOException HANDLE
mh <- IO HANDLE -> IO (Either IOException HANDLE)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO HANDLE -> IO (Either IOException HANDLE))
-> IO HANDLE -> IO (Either IOException HANDLE)
forall a b. (a -> b) -> a -> b
$
              String
-> ErrCode
-> ErrCode
-> Maybe LPSECURITY_ATTRIBUTES
-> ErrCode
-> ErrCode
-> Maybe HANDLE
-> IO HANDLE
createFile String
fileName
                         ErrCode
dwDesiredAccess
                         ErrCode
dwSharedMode
                         Maybe LPSECURITY_ATTRIBUTES
lpSecurityAttributes
                         ErrCode
dwCreationDisposition
                         ErrCode
dwFlagsAndAttributes
                         Maybe HANDLE
hTemplateFile
      case Either IOException HANDLE
mh :: Either IOException HANDLE of
        Left IOException
e -> do
          ErrCode
errorCode <- IO ErrCode
getLastError
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ErrCode
errorCode ErrCode -> ErrCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ErrCode
eRROR_PIPE_BUSY)
            (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IOException -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOException
e
          -- all pipe instance were busy, wait 20s and retry; we ignore the

          -- result

          Bool
_ <- String -> ErrCode -> IO Bool
waitNamedPipe String
fileName ErrCode
5_000
          IO HANDLE
connectLoop

        Right HANDLE
h -> HANDLE -> IO HANDLE
forall (f :: * -> *) a. Applicative f => a -> f a
pure HANDLE
h


-- | [ERROR_PIPE_BUSY](https://docs.microsoft.com/en-us/windows/win32/debug/system-error-codes--0-499-#ERROR_PIPE_BUSY):

-- all pipe instances are busy.

--

eRROR_PIPE_BUSY :: ErrCode
eRROR_PIPE_BUSY :: ErrCode
eRROR_PIPE_BUSY = ErrCode
231
{-# LINE 275 "System\\Win32\\NamedPipes.hsc" #-}

eRROR_SEM_TIMEOUT :: ErrCode
eRROR_SEM_TIMEOUT :: ErrCode
eRROR_SEM_TIMEOUT = ErrCode
121
{-# LINE 278 "System\\Win32\\NamedPipes.hsc" #-}