|
| 1 | +#include <fcntl.h> |
| 2 | +#include <windows.h> |
| 3 | + |
| 4 | +{-# LANGUAGE CPP #-} |
| 5 | +{-# LANGUAGE BangPatterns #-} |
| 6 | +{-# LANGUAGE MultiWayIf #-} |
| 7 | +{-# LANGUAGE NumericUnderscores #-} |
| 8 | + |
| 9 | +-- | For full details on the Windows named pipes API see |
| 10 | +-- <https://docs.microsoft.com/en-us/windows/desktop/ipc/named-pipes> |
| 11 | +-- |
| 12 | +module System.Win32.NamedPipes ( |
| 13 | + |
| 14 | + -- * Named pipe server APIs |
| 15 | + createNamedPipe, |
| 16 | + pIPE_UNLIMITED_INSTANCES, |
| 17 | + |
| 18 | + -- ** Parameter types |
| 19 | + LPSECURITY_ATTRIBUTES, |
| 20 | + OpenMode, |
| 21 | + pIPE_ACCESS_DUPLEX, |
| 22 | + pIPE_ACCESS_INBOUND, |
| 23 | + pIPE_ACCESS_OUTBOUND, |
| 24 | + fILE_FLAG_OVERLAPPED, |
| 25 | + PipeMode, |
| 26 | + pIPE_TYPE_BYTE, |
| 27 | + pIPE_TYPE_MESSAGE, |
| 28 | + pIPE_READMODE_BYTE, |
| 29 | + pIPE_READMODE_MESSAGE, |
| 30 | + pIPE_WAIT, |
| 31 | + pIPE_NOWAIT, |
| 32 | + pIPE_ACCEPT_REMOTE_CLIENTS, |
| 33 | + pIPE_REJECT_REMOTE_CLIENTS, |
| 34 | + |
| 35 | + -- * Named pipe client APIs |
| 36 | + -- ** connect to a named pipe |
| 37 | + connect, |
| 38 | + |
| 39 | + -- ** waiting for named pipe instances |
| 40 | + waitNamedPipe, |
| 41 | + |
| 42 | + TimeOut, |
| 43 | + nMPWAIT_USE_DEFAULT_WAIT, |
| 44 | + nMPWAIT_WAIT_FOREVER, |
| 45 | + ) where |
| 46 | + |
| 47 | + |
| 48 | +import Control.Exception |
| 49 | +import Control.Monad (when) |
| 50 | +import Foreign.C.String (withCString) |
| 51 | + |
| 52 | +import System.Win32.Types hiding (try) |
| 53 | +import System.Win32.File |
| 54 | + |
| 55 | +-- | The named pipe open mode. |
| 56 | +-- |
| 57 | +-- This must specify one of: |
| 58 | +-- |
| 59 | +-- * 'pIPE_ACCESS_DUPLEX' |
| 60 | +-- * 'pIPE_ACCESS_INBOUND' |
| 61 | +-- * 'pIPE_ACCESS_OUTBOUND' |
| 62 | +-- |
| 63 | +-- It may also specify: |
| 64 | +-- |
| 65 | +-- * 'fILE_FLAG_WRITE_THROUGH' |
| 66 | +-- * 'fILE_FLAG_OVERLAPPED' |
| 67 | +-- |
| 68 | +-- It may also specify any combination of: |
| 69 | +-- |
| 70 | +-- * 'wRITE_DAC' |
| 71 | +-- * 'wRITE_OWNER' |
| 72 | +-- * 'aCCESS_SYSTEM_SECURITY' |
| 73 | +-- |
| 74 | +type OpenMode = UINT |
| 75 | + |
| 76 | +#{enum OpenMode, |
| 77 | + , pIPE_ACCESS_DUPLEX = PIPE_ACCESS_DUPLEX |
| 78 | + , pIPE_ACCESS_INBOUND = PIPE_ACCESS_INBOUND |
| 79 | + , pIPE_ACCESS_OUTBOUND = PIPE_ACCESS_OUTBOUND |
| 80 | + } |
| 81 | + |
| 82 | +-- | The pipe mode. |
| 83 | +-- |
| 84 | +-- One of the following type modes can be specified. The same type mode must be |
| 85 | +-- specified for each instance of the pipe. |
| 86 | +-- |
| 87 | +-- * 'pIPE_TYPE_BYTE' |
| 88 | +-- * 'pIPE_TYPE_MESSAGE' |
| 89 | +-- |
| 90 | +-- One of the following read modes can be specified. Different instances of the |
| 91 | +-- same pipe can specify different read modes. |
| 92 | +-- |
| 93 | +-- * 'pIPE_READMODE_BYTE' |
| 94 | +-- * 'pIPE_READMODE_MESSAGE' |
| 95 | +-- |
| 96 | +-- One of the following wait modes can be specified. Different instances of the |
| 97 | +-- same pipe can specify different wait modes. |
| 98 | +-- |
| 99 | +-- * 'pIPE_WAIT' |
| 100 | +-- * 'pIPE_NOWAIT' |
| 101 | +-- |
| 102 | +-- One of the following remote-client modes can be specified. Different |
| 103 | +-- instances of the same pipe can specify different remote-client modes. |
| 104 | +-- |
| 105 | +-- * 'pIPE_ACCEPT_REMOTE_CLIENT' |
| 106 | +-- * 'pIPE_REJECT_REMOTE_CLIENT' |
| 107 | +-- |
| 108 | +type PipeMode = UINT |
| 109 | + |
| 110 | +#{enum PipeMode, |
| 111 | + , pIPE_TYPE_BYTE = PIPE_TYPE_BYTE |
| 112 | + , pIPE_TYPE_MESSAGE = PIPE_TYPE_MESSAGE |
| 113 | + , pIPE_READMODE_BYTE = PIPE_READMODE_BYTE |
| 114 | + , pIPE_READMODE_MESSAGE = PIPE_READMODE_MESSAGE |
| 115 | + , pIPE_WAIT = PIPE_WAIT |
| 116 | + , pIPE_NOWAIT = PIPE_NOWAIT |
| 117 | + , pIPE_ACCEPT_REMOTE_CLIENTS = PIPE_ACCEPT_REMOTE_CLIENTS |
| 118 | + , pIPE_REJECT_REMOTE_CLIENTS = PIPE_REJECT_REMOTE_CLIENTS |
| 119 | + } |
| 120 | + |
| 121 | +-- | If the 'createNamedPipe' @nMaxInstances@ parameter is |
| 122 | +-- 'pIPE_UNLIMITED_INSTANCES', the number of pipe instances that can be created |
| 123 | +-- is limited only by the availability of system resources. |
| 124 | +pIPE_UNLIMITED_INSTANCES :: DWORD |
| 125 | +pIPE_UNLIMITED_INSTANCES = #const PIPE_UNLIMITED_INSTANCES |
| 126 | + |
| 127 | +-- | Creates an instance of a named pipe and returns a handle for subsequent |
| 128 | +-- pipe operations. A named pipe server process uses this function either to |
| 129 | +-- create the first instance of a specific named pipe and establish its basic |
| 130 | +-- attributes or to create a new instance of an existing named pipe. |
| 131 | +-- |
| 132 | +-- For full details see |
| 133 | +-- <https://docs.microsoft.com/en-us/windows/desktop/api/winbase/nf-winbase-createnamedpipea> |
| 134 | +-- |
| 135 | +-- To create a named pipe which can be associate with IO completion port on |
| 136 | +-- needs to pass 'fILE_FLAG_OVERLAPPED' to 'OpenMode' argument, |
| 137 | +-- e.g. |
| 138 | +-- |
| 139 | +-- > Win32.createNamedPipe pipeName |
| 140 | +-- > (pIPE_ACCESS_DUPLEX .|. fILE_FLAG_OVERLAPPED) |
| 141 | +-- > (pIPE_TYPE_BYTE .|. pIPE_READMODE_BYTE) |
| 142 | +-- > pIPE_UNLIMITED_INSTANCES |
| 143 | +-- > 512 |
| 144 | +-- > 512 |
| 145 | +-- > 0 |
| 146 | +-- > NothinROR |
| 147 | +-- |
| 148 | +-- |
| 149 | +createNamedPipe :: String -- ^ A unique pipe name of the form @\\.\pipe\{pipename}@ |
| 150 | + -- The `pipename` part of the name can include any |
| 151 | + -- character other than a backslash, including |
| 152 | + -- numbers and special characters. The entire pipe |
| 153 | + -- name string can be up to 256 characters long. |
| 154 | + -- Pipe names are not case sensitive. |
| 155 | + -> OpenMode |
| 156 | + -> PipeMode |
| 157 | + -> DWORD -- ^ nMaxInstances |
| 158 | + -> DWORD -- ^ nOutBufferSize |
| 159 | + -> DWORD -- ^ nInBufferSize |
| 160 | + -> DWORD -- ^ nDefaultTimeOut |
| 161 | + -> Maybe LPSECURITY_ATTRIBUTES |
| 162 | + -> IO HANDLE |
| 163 | +createNamedPipe name openMode pipeMode |
| 164 | + nMaxInstances nOutBufferSize nInBufferSize |
| 165 | + nDefaultTimeOut mb_attr = |
| 166 | + withTString name $ \ c_name -> |
| 167 | + failIf (==iNVALID_HANDLE_VALUE) ("CreateNamedPipe ('" ++ name ++ "')") $ |
| 168 | + c_CreateNamedPipe c_name openMode pipeMode |
| 169 | + nMaxInstances nOutBufferSize nInBufferSize |
| 170 | + nDefaultTimeOut (maybePtr mb_attr) |
| 171 | + |
| 172 | +foreign import ccall unsafe "windows.h CreateNamedPipeW" |
| 173 | + c_CreateNamedPipe :: LPCTSTR |
| 174 | + -> DWORD |
| 175 | + -> DWORD |
| 176 | + -> DWORD |
| 177 | + -> DWORD |
| 178 | + -> DWORD |
| 179 | + -> DWORD |
| 180 | + -> LPSECURITY_ATTRIBUTES |
| 181 | + -> IO HANDLE |
| 182 | + |
| 183 | + |
| 184 | +-- | Timeout in milliseconds. |
| 185 | +-- |
| 186 | +-- * 'nMPWAIT_USE_DEFAULT_WAIT' indicates that the timeout value passed to |
| 187 | +-- 'createNamedPipe' should be used. |
| 188 | +-- * 'nMPWAIT_WAIT_FOREVER' - 'waitNamedPipe' will block forever, until a named |
| 189 | +-- pipe instance is available. |
| 190 | +-- |
| 191 | +type TimeOut = DWORD |
| 192 | +#{enum TimeOut, |
| 193 | + , nMPWAIT_USE_DEFAULT_WAIT = NMPWAIT_USE_DEFAULT_WAIT |
| 194 | + , nMPWAIT_WAIT_FOREVER = NMPWAIT_WAIT_FOREVER |
| 195 | + } |
| 196 | + |
| 197 | + |
| 198 | +-- | Wait until a named pipe instance is available. If there is no instance at |
| 199 | +-- hand before the timeout, it will error with 'ERROR_SEM_TIMEOUT', i.e. |
| 200 | +-- @invalid argument (The semaphore timeout period has expired)@ |
| 201 | +-- |
| 202 | +-- It returns 'True' if there is an available instance, subsequent 'createFile' |
| 203 | +-- might still fail, if another thread will take turn and connect before, or if |
| 204 | +-- the other end shuts down the name pipe. |
| 205 | +-- |
| 206 | +-- It returns 'False' if timeout fired. |
| 207 | +-- |
| 208 | +waitNamedPipe :: String -- ^ pipe name |
| 209 | + -> TimeOut -- ^ nTimeOut |
| 210 | + -> IO Bool |
| 211 | +waitNamedPipe name timeout = |
| 212 | + withCString name $ \ c_name -> do |
| 213 | + r <- c_WaitNamedPipe c_name timeout |
| 214 | + e <- getLastError |
| 215 | + if | r -> pure r |
| 216 | + | e == eRROR_SEM_TIMEOUT -> pure False |
| 217 | + | otherwise -> failWith "waitNamedPipe" e |
| 218 | + |
| 219 | + |
| 220 | +-- 'c_WaitNamedPipe' is a blocking call, hence the _safe_ import. |
| 221 | +foreign import ccall safe "windows.h WaitNamedPipeA" |
| 222 | + c_WaitNamedPipe :: LPCSTR -- lpNamedPipeName |
| 223 | + -> DWORD -- nTimeOut |
| 224 | + -> IO BOOL |
| 225 | + |
| 226 | +-- | A reliable connect call, as designed in |
| 227 | +-- <https://docs.microsoft.com/en-us/windows/win32/ipc/named-pipe-client> |
| 228 | +-- |
| 229 | +-- The arguments are passed directly to 'createFile'. |
| 230 | +-- |
| 231 | +-- Note we pick the more familiar posix naming convention, do not confuse this |
| 232 | +-- function with 'connectNamedPipe' (which corresponds to posix 'accept') |
| 233 | +-- |
| 234 | +connect :: String -- ^ file name |
| 235 | + -> AccessMode -- ^ dwDesiredAccess |
| 236 | + -> ShareMode -- ^ dwSharedMode |
| 237 | + -> Maybe LPSECURITY_ATTRIBUTES -- ^ lpSecurityAttributes |
| 238 | + -> CreateMode -- ^ dwCreationDisposition |
| 239 | + -> FileAttributeOrFlag -- ^ dwFlagsAndAttributes |
| 240 | + -> Maybe HANDLE -- ^ hTemplateFile |
| 241 | + -> IO HANDLE |
| 242 | +connect fileName dwDesiredAccess dwSharedMode lpSecurityAttributes dwCreationDisposition dwFlagsAndAttributes hTemplateFile = connectLoop |
| 243 | + where |
| 244 | + connectLoop = do |
| 245 | + -- `createFile` checks for `INVALID_HANDLE_VALUE` and retries if this is |
| 246 | + -- caused by `ERROR_SHARING_VIOLATION`. |
| 247 | + mh <- try $ |
| 248 | + createFile fileName |
| 249 | + dwDesiredAccess |
| 250 | + dwSharedMode |
| 251 | + lpSecurityAttributes |
| 252 | + dwCreationDisposition |
| 253 | + dwFlagsAndAttributes |
| 254 | + hTemplateFile |
| 255 | + case mh :: Either IOException HANDLE of |
| 256 | + Left e -> do |
| 257 | + errorCode <- getLastError |
| 258 | + when (errorCode /= eRROR_PIPE_BUSY) |
| 259 | + $ throwIO e |
| 260 | + -- all pipe instance were busy, wait 20s and retry; we ignore the |
| 261 | + -- result |
| 262 | + _ <- waitNamedPipe fileName 5_000 |
| 263 | + connectLoop |
| 264 | + |
| 265 | + Right h -> pure h |
| 266 | + |
| 267 | + |
| 268 | +-- | [ERROR_PIPE_BUSY](https://docs.microsoft.com/en-us/windows/win32/debug/system-error-codes--0-499-#ERROR_PIPE_BUSY): |
| 269 | +-- all pipe instances are busy. |
| 270 | +-- |
| 271 | +eRROR_PIPE_BUSY :: ErrCode |
| 272 | +eRROR_PIPE_BUSY = #const ERROR_PIPE_BUSY |
| 273 | + |
| 274 | +eRROR_SEM_TIMEOUT :: ErrCode |
| 275 | +eRROR_SEM_TIMEOUT = #const ERROR_SEM_TIMEOUT |
0 commit comments