├── .github ├── CODEOWNERS └── workflows │ ├── release.yaml │ └── build.yaml ├── src ├── Posix │ ├── Select.hs │ ├── Types.hsc │ ├── MessageQueue │ │ └── Types.hsc │ ├── Struct │ │ ├── SocketAddressInternet │ │ │ └── Peek.hsc │ │ └── AddressInfo │ │ │ ├── Peek.hsc │ │ │ └── Poke.hsc │ ├── Poll.hs │ ├── Directory.hs │ ├── File │ │ └── Types.hsc │ ├── MessageQueue.hs │ ├── Poll │ │ └── Types.hsc │ ├── File.hs │ ├── Socket │ │ └── Types.hsc │ └── Socket.hs ├── Linux │ ├── MessageQueue.hs │ ├── MessageQueue │ │ └── Types.hsc │ ├── Socket.hs │ ├── Epoll.hs │ ├── Socket │ │ └── Types.hsc │ └── Epoll │ │ └── Types.hsc └── Foreign │ └── C │ └── String │ └── Managed.hs ├── .gitignore ├── src-noassertions └── Assertion.hs ├── src-assertions └── Assertion.hs ├── include ├── HaskellPosix.h └── custom.h ├── LICENSE ├── fourmolu.yaml ├── README.md ├── CHANGELOG.md ├── posix-api.cabal ├── src-linux └── Posix │ └── Socket │ └── Platform.hsc ├── test └── Main.hs └── cbits └── HaskellPosix.c /.github/CODEOWNERS: -------------------------------------------------------------------------------- 1 | @byteverse/l3c 2 | -------------------------------------------------------------------------------- /src/Posix/Select.hs: -------------------------------------------------------------------------------- 1 | module Posix.Select 2 | ( 3 | ) where 4 | -------------------------------------------------------------------------------- /src/Linux/MessageQueue.hs: -------------------------------------------------------------------------------- 1 | module Linux.MessageQueue 2 | ( module X 3 | ) where 4 | 5 | import Linux.MessageQueue.Types as X 6 | -------------------------------------------------------------------------------- /.github/workflows/release.yaml: -------------------------------------------------------------------------------- 1 | name: release 2 | on: 3 | push: 4 | tags: 5 | - "*" 6 | 7 | jobs: 8 | call-workflow: 9 | uses: byteverse/.github/.github/workflows/release.yaml@main 10 | secrets: inherit 11 | -------------------------------------------------------------------------------- /.github/workflows/build.yaml: -------------------------------------------------------------------------------- 1 | name: build 2 | on: 3 | pull_request: 4 | branches: 5 | - "*" 6 | 7 | jobs: 8 | call-workflow: 9 | uses: byteverse/.github/.github/workflows/build-matrix.yaml@main 10 | with: 11 | cabal-file: posix-api.cabal 12 | -------------------------------------------------------------------------------- /src/Posix/Types.hsc: -------------------------------------------------------------------------------- 1 | {-# language DataKinds #-} 2 | {-# language DerivingStrategies #-} 3 | {-# language DuplicateRecordFields #-} 4 | {-# language GeneralizedNewtypeDeriving #-} 5 | 6 | module Posix.Types 7 | ( CNfds(..) 8 | ) where 9 | 10 | import System.Posix.Types (CNfds(..)) 11 | 12 | #include 13 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .vscode/ 2 | dist 3 | dist-* 4 | cabal-dev 5 | *.o 6 | *.hi 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | *.eventlog 19 | .stack-work/ 20 | cabal.project.local 21 | cabal.project.local~ 22 | .HTF/ 23 | .ghc.environment.* 24 | stack.yaml 25 | *.swm 26 | *.swo 27 | *.swp 28 | test_results/** 29 | *.dump-simpl 30 | -------------------------------------------------------------------------------- /src-noassertions/Assertion.hs: -------------------------------------------------------------------------------- 1 | module Assertion 2 | ( assertByteArrayPinned 3 | , assertMutableByteArrayPinned 4 | , assertMutablePrimArrayPinned 5 | ) where 6 | 7 | import qualified Data.Primitive as PM 8 | 9 | assertMutablePrimArrayPinned :: PM.MutablePrimArray s a -> PM.MutablePrimArray s a 10 | assertMutablePrimArrayPinned = id 11 | 12 | assertMutableByteArrayPinned :: PM.MutableByteArray s -> PM.MutableByteArray s 13 | assertMutableByteArrayPinned = id 14 | 15 | assertByteArrayPinned :: PM.ByteArray -> PM.ByteArray 16 | assertByteArrayPinned = id 17 | -------------------------------------------------------------------------------- /src/Linux/MessageQueue/Types.hsc: -------------------------------------------------------------------------------- 1 | {-# language DataKinds #-} 2 | {-# language DerivingStrategies #-} 3 | {-# language DuplicateRecordFields #-} 4 | {-# language GeneralizedNewtypeDeriving #-} 5 | {-# language BinaryLiterals #-} 6 | {-# language TypeApplications #-} 7 | 8 | #include 9 | module Linux.MessageQueue.Types 10 | ( -- * Open flags 11 | closeOnExec 12 | ) where 13 | 14 | import Posix.MessageQueue.Types (OpenFlags(..)) 15 | 16 | -- | The @O_CLOEXEC@ open flag. 17 | closeOnExec :: OpenFlags 18 | closeOnExec = OpenFlags #{const O_CLOEXEC} 19 | -------------------------------------------------------------------------------- /src/Posix/MessageQueue/Types.hsc: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | module Posix.MessageQueue.Types 5 | ( OpenMode(..) 6 | , OpenFlags(..) 7 | -- * Open Flags 8 | , nonblocking 9 | ) where 10 | 11 | import Data.Bits ((.|.)) 12 | import Foreign.C.Types (CInt(..)) 13 | 14 | newtype OpenMode = OpenMode CInt 15 | 16 | newtype OpenFlags = OpenFlags CInt 17 | 18 | instance Semigroup OpenFlags where 19 | OpenFlags x <> OpenFlags y = OpenFlags (x .|. y) 20 | instance Monoid OpenFlags where mempty = OpenFlags 0 21 | 22 | -- | The @O_NONBLOCK@ open flag. 23 | nonblocking :: OpenFlags 24 | nonblocking = OpenFlags #{const O_NONBLOCK} 25 | -------------------------------------------------------------------------------- /src-assertions/Assertion.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | 3 | module Assertion 4 | ( assertByteArrayPinned 5 | , assertMutableByteArrayPinned 6 | , assertMutablePrimArrayPinned 7 | ) where 8 | 9 | import qualified Data.Primitive as PM 10 | 11 | assertMutablePrimArrayPinned :: PM.MutablePrimArray s a -> PM.MutablePrimArray s a 12 | assertMutablePrimArrayPinned x = 13 | if PM.isMutablePrimArrayPinned x 14 | then x 15 | else error "assertMutablePrimArrayPinned" 16 | 17 | assertMutableByteArrayPinned :: PM.MutableByteArray s -> PM.MutableByteArray s 18 | assertMutableByteArrayPinned x = 19 | if PM.isMutableByteArrayPinned x 20 | then x 21 | else error "assertMutableByteArrayPinned" 22 | 23 | assertByteArrayPinned :: PM.ByteArray -> PM.ByteArray 24 | assertByteArrayPinned x = 25 | if PM.isByteArrayPinned x 26 | then x 27 | else error "assertByteArrayPinned" 28 | -------------------------------------------------------------------------------- /include/HaskellPosix.h: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "Rts.h" 5 | 6 | ssize_t read_offset(int socket, char *buffer, HsInt offset, size_t length); 7 | ssize_t recv_offset(int socket, char *buffer, HsInt offset, size_t length, int flags); 8 | ssize_t send_offset(int socket, const char *buffer, HsInt offset, size_t length, int flags); 9 | 10 | ssize_t sendto_offset(int socket, const char *message, HsInt offset, size_t length, int flags, const struct sockaddr *dest_addr, socklen_t dest_len); 11 | ssize_t sendto_inet_offset(int socket, const char *message, HsInt offset, size_t length, int flags, uint16_t port, uint32_t inet_addr); 12 | ssize_t recvfrom_offset(int socket, char *restrict buffer, HsInt offset, size_t length, int flags, struct sockaddr *restrict address, socklen_t *restrict address_len); 13 | 14 | int setsockopt_int(int socket, int level, int option_name, int option_value); 15 | 16 | int recvmmsg_sockaddr_in (int sockfd , int *lens , struct sockaddr_in *addrs 17 | , StgArrBytes **bufs // used for output 18 | , unsigned int vlen , int flags); 19 | 20 | int recvmmsg_sockaddr_discard (int sockfd , int *lens 21 | , StgArrBytes **bufs // used for output 22 | , unsigned int vlen , int flags); 23 | -------------------------------------------------------------------------------- /src/Posix/Struct/SocketAddressInternet/Peek.hsc: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | {-# language DataKinds #-} 6 | 7 | -- | Accessors for reading from @struct sockaddr_in@: 8 | -- 9 | -- > struct sockaddr_in { 10 | -- > sa_family_t sin_family; /* address family: AF_INET */ 11 | -- > in_port_t sin_port; /* port in network byte order */ 12 | -- > struct in_addr sin_addr; /* internet address */ 13 | -- > }; 14 | module Posix.Struct.SocketAddressInternet.Peek 15 | ( family 16 | , port 17 | , address 18 | ) where 19 | 20 | import Posix.Socket.Types (SocketAddressInternet,Family) 21 | import Foreign.Ptr (Ptr) 22 | import Foreign.Storable (peekByteOff) 23 | import Data.Word (Word16,Word32) 24 | import System.ByteOrder (Fixed,ByteOrder(BigEndian)) 25 | 26 | -- | Get @sin_family@. 27 | family :: Ptr SocketAddressInternet -> IO Family 28 | family = #{peek struct sockaddr_in, sin_family} 29 | 30 | -- | Get @in_port_t@. 31 | port :: Ptr SocketAddressInternet -> IO (Fixed 'BigEndian Word16) 32 | port = #{peek struct sockaddr_in, sin_port} 33 | 34 | -- | Get @sin_addr.saddr@. This works on Linux because @struct in_addr@ has 35 | -- a single 32-bit field. I do not know how to perform this in a portable way 36 | -- with hsc2hs. 37 | address :: Ptr SocketAddressInternet -> IO (Fixed 'BigEndian Word32) 38 | address = #{peek struct sockaddr_in, sin_addr} 39 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, Andrew Martin 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Andrew Martin nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /src/Posix/Poll.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE UnliftedFFITypes #-} 4 | 5 | module Posix.Poll 6 | ( uninterruptiblePoll 7 | , uninterruptiblePollMutablePrimArray 8 | , PollFd (..) 9 | , Exchange (..) 10 | , PT.input 11 | , PT.output 12 | , PT.error 13 | , PT.hangup 14 | , PT.invalid 15 | , PT.isSubeventOf 16 | ) where 17 | 18 | import Data.Primitive (MutablePrimArray (..)) 19 | import Foreign.C.Error (Errno, getErrno) 20 | import Foreign.C.Types (CInt (..)) 21 | import GHC.Exts (MutableByteArray#, RealWorld) 22 | import GHC.Ptr (Ptr) 23 | import Posix.Poll.Types (Exchange (..), PollFd (..)) 24 | import Posix.Types (CNfds (..)) 25 | 26 | import qualified Posix.Poll.Types as PT 27 | 28 | foreign import ccall unsafe "poll.h poll" 29 | c_poll_ptr :: Ptr PollFd -> CNfds -> CInt -> IO CInt 30 | 31 | foreign import ccall unsafe "poll.h poll" 32 | c_poll_prim_array :: MutableByteArray# RealWorld -> CNfds -> CInt -> IO CInt 33 | 34 | {- | The @timeout@ argument is omitted since it is nonsense to choose 35 | anything other than 0 when using the unsafe FFI. 36 | -} 37 | uninterruptiblePoll :: 38 | Ptr PollFd -> 39 | CNfds -> 40 | IO (Either Errno CInt) 41 | uninterruptiblePoll pfds n = 42 | c_poll_ptr pfds n 0 >>= errorsFromInt 43 | 44 | uninterruptiblePollMutablePrimArray :: 45 | MutablePrimArray RealWorld PollFd -> 46 | CNfds -> 47 | IO (Either Errno CInt) 48 | uninterruptiblePollMutablePrimArray (MutablePrimArray pfds) n = 49 | c_poll_prim_array pfds n 0 >>= errorsFromInt 50 | 51 | errorsFromInt :: CInt -> IO (Either Errno CInt) 52 | errorsFromInt r = 53 | if r >= 0 54 | then pure (Right r) 55 | else fmap Left getErrno 56 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | # Number of spaces per indentation step 2 | indentation: 2 3 | 4 | # Max line length for automatic line breaking 5 | column-limit: 200 6 | 7 | # Styling of arrows in type signatures (choices: trailing, leading, or leading-args) 8 | function-arrows: trailing 9 | 10 | # How to place commas in multi-line lists, records, etc. (choices: leading or trailing) 11 | comma-style: leading 12 | 13 | # Styling of import/export lists (choices: leading, trailing, or diff-friendly) 14 | import-export-style: leading 15 | 16 | # Whether to full-indent or half-indent 'where' bindings past the preceding body 17 | indent-wheres: false 18 | 19 | # Whether to leave a space before an opening record brace 20 | record-brace-space: true 21 | 22 | # Number of spaces between top-level declarations 23 | newlines-between-decls: 1 24 | 25 | # How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) 26 | haddock-style: multi-line 27 | 28 | # How to print module docstring 29 | haddock-style-module: null 30 | 31 | # Styling of let blocks (choices: auto, inline, newline, or mixed) 32 | let-style: auto 33 | 34 | # How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) 35 | in-style: right-align 36 | 37 | # Whether to put parentheses around a single constraint (choices: auto, always, or never) 38 | single-constraint-parens: always 39 | 40 | # Output Unicode syntax (choices: detect, always, or never) 41 | unicode: never 42 | 43 | # Give the programmer more choice on where to insert blank lines 44 | respectful: true 45 | 46 | # Fixity information for operators 47 | fixities: [] 48 | 49 | # Module reexports Fourmolu should know about 50 | reexports: [] 51 | 52 | -------------------------------------------------------------------------------- /src/Posix/Struct/AddressInfo/Peek.hsc: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | {-# language DataKinds #-} 6 | 7 | -- | Accessors for reading from @struct addrinfo@: 8 | -- 9 | -- > struct addrinfo { 10 | -- > int ai_flags; 11 | -- > int ai_family; 12 | -- > int ai_socktype; 13 | -- > int ai_protocol; 14 | -- > socklen_t ai_addrlen; 15 | -- > struct sockaddr *ai_addr; 16 | -- > char *ai_canonname; 17 | -- > struct addrinfo *ai_next; 18 | -- > }; 19 | module Posix.Struct.AddressInfo.Peek 20 | ( flags 21 | , family 22 | , socketType 23 | , protocol 24 | , addressLength 25 | , address 26 | , next 27 | ) where 28 | 29 | import Posix.Socket.Types (AddressInfoFlags(..),SocketAddress,Family,Type,AddressInfo,Protocol) 30 | import Foreign.C.Types (CInt) 31 | import Foreign.Ptr (Ptr) 32 | import Foreign.Storable (peekByteOff) 33 | 34 | -- | Get @ai_flags@. 35 | flags :: Ptr AddressInfo -> IO AddressInfoFlags 36 | flags ptr = #{peek struct addrinfo, ai_flags} ptr 37 | 38 | -- | Get @ai_family@. 39 | family :: Ptr AddressInfo -> IO Family 40 | family ptr = #{peek struct addrinfo, ai_family} ptr 41 | 42 | -- | Get @ai_socktype@. 43 | socketType :: Ptr AddressInfo -> IO Type 44 | socketType ptr = #{peek struct addrinfo, ai_socktype} ptr 45 | 46 | -- | Get @ai_protocol@. 47 | protocol :: Ptr AddressInfo -> IO Protocol 48 | protocol ptr = #{peek struct addrinfo, ai_protocol} ptr 49 | 50 | -- | Get @ai_addrlen@. 51 | addressLength :: Ptr AddressInfo -> IO CInt 52 | addressLength ptr = #{peek struct addrinfo, ai_addrlen} ptr 53 | 54 | -- | Get @ai_addr@. 55 | address :: Ptr AddressInfo -> IO (Ptr SocketAddress) 56 | address ptr = #{peek struct addrinfo, ai_addr} ptr 57 | 58 | -- | Get @ai_next@. 59 | next :: Ptr AddressInfo -> IO (Ptr AddressInfo) 60 | next ptr = #{peek struct addrinfo, ai_next} ptr 61 | -------------------------------------------------------------------------------- /src/Posix/Struct/AddressInfo/Poke.hsc: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | {-# language DataKinds #-} 6 | 7 | -- | Setters for assigning fields of @struct addrinfo@: 8 | -- 9 | -- > struct addrinfo { 10 | -- > int ai_flags; 11 | -- > int ai_family; 12 | -- > int ai_socktype; 13 | -- > int ai_protocol; 14 | -- > socklen_t ai_addrlen; 15 | -- > struct sockaddr *ai_addr; 16 | -- > char *ai_canonname; 17 | -- > struct addrinfo *ai_next; 18 | -- > }; 19 | module Posix.Struct.AddressInfo.Poke 20 | ( flags 21 | , family 22 | , socketType 23 | , protocol 24 | , addressLength 25 | , address 26 | , next 27 | ) where 28 | 29 | import Posix.Socket.Types (AddressInfoFlags(..),SocketAddress,Family,Type,AddressInfo,Protocol) 30 | import Foreign.C.Types (CInt) 31 | import Foreign.Ptr (Ptr) 32 | import Foreign.Storable (pokeByteOff) 33 | 34 | -- | Get @ai_flags@. 35 | flags :: Ptr AddressInfo -> AddressInfoFlags -> IO () 36 | flags ptr = #{poke struct addrinfo, ai_flags} ptr 37 | 38 | -- | Get @ai_family@. 39 | family :: Ptr AddressInfo -> Family -> IO () 40 | family ptr = #{poke struct addrinfo, ai_family} ptr 41 | 42 | -- | Get @ai_socktype@. 43 | socketType :: Ptr AddressInfo -> Type -> IO () 44 | socketType ptr = #{poke struct addrinfo, ai_socktype} ptr 45 | 46 | -- | Get @ai_protocol@. 47 | protocol :: Ptr AddressInfo -> Protocol -> IO () 48 | protocol ptr = #{poke struct addrinfo, ai_protocol} ptr 49 | 50 | -- | Get @ai_addrlen@. 51 | addressLength :: Ptr AddressInfo -> CInt -> IO () 52 | addressLength ptr = #{poke struct addrinfo, ai_addrlen} ptr 53 | 54 | -- | Get @ai_addr@. 55 | address :: Ptr AddressInfo -> Ptr SocketAddress -> IO () 56 | address ptr = #{poke struct addrinfo, ai_addr} ptr 57 | 58 | -- | Get @ai_next@. 59 | next :: Ptr AddressInfo -> Ptr AddressInfo -> IO () 60 | next ptr = #{poke struct addrinfo, ai_next} ptr 61 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # posix-api 2 | 3 | ## Objective 4 | 5 | This library provides minimal bindings to system calls for POSIX-compliant 6 | operating systems. All functions follow these design decisions: 7 | 8 | * `String` is not used anywhere. `ByteArray` (from `primitive`) is used for 9 | serialized data. It is also used in certain filesystem function variants 10 | used in contexts where the paths are only ever handed over to other 11 | filesystem functions. `Addr` (from `primitive`) is used for pointers to 12 | data whose type is unknown. `Ptr` is used for pointers to data whose type 13 | is known. 14 | * Functions should not throw errors. This library uses `IO (Either Errno a)` 15 | in places where some libraries would use `IO a`. 16 | * The numeric types from `Foreign.C.Types` and `System.Posix.Types` are 17 | used in the type signatures of functions so that a haskell function's 18 | type signature matches its underlying POSIX equivalent exactly. 19 | * Flags are newtypes over `CInt` (or whatever integral type matches the 20 | posix specification) rather than enumerations. The data constructors 21 | are exported, making the types extensible for operating system that 22 | have additional flags. 23 | * There is some platform-specific code in this library. POSIX-specified data 24 | structures do not have the same in-memory representation on all platforms. 25 | Consequently, some of the code to serialize data to its C-struct 26 | representation must be written differently on different platforms. 27 | This is seldom needed. A viable alternative would be using the FFI 28 | to perform this serialization. However, the approach of using 29 | per-platform haskell code lets the serialization code inline better. 30 | 31 | Pull requests that add bindings to POSIX APIs in a way that agrees 32 | with these guidelines will be accepted. Unfortunately, there is some 33 | grey area when it comes to what a "minimal binding" to a function 34 | is. Discussion may sometimes be necessary to refine the guidelines. 35 | 36 | ## Infelicities 37 | 38 | This project currently includes some Linux-specific code. It in the 39 | the `Linux.Socket`. The plan is to eventually move the `Linux.Socket` module 40 | into its own library. Currently, a ton of POSIX APIs are missing. 41 | These should be included. 42 | 43 | -------------------------------------------------------------------------------- /src/Posix/Directory.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | module Posix.Directory 5 | ( getCurrentWorkingDirectory 6 | ) where 7 | 8 | import Data.Primitive (ByteArray) 9 | import Foreign.C.Error (Errno, eRANGE, getErrno) 10 | import Foreign.C.Types (CChar, CSize (..)) 11 | import Foreign.Ptr (nullPtr) 12 | import GHC.Exts (Ptr (..)) 13 | 14 | import qualified Data.Primitive as PM 15 | import qualified Foreign.Storable as FS 16 | 17 | foreign import ccall safe "getcwd" 18 | c_getcwd :: Ptr CChar -> CSize -> IO (Ptr CChar) 19 | 20 | {- | Get the current working directory without using the system locale 21 | to convert it to text. This is implemented with a safe FFI call 22 | since it may block. 23 | -} 24 | getCurrentWorkingDirectory :: IO (Either Errno ByteArray) 25 | getCurrentWorkingDirectory = go (4096 - chunkOverhead) 26 | where 27 | go !sz = do 28 | -- It may be nice to add a variant of getCurrentWorkingDirectory that 29 | -- allow the user to supply an initial pinned buffer. I'm not sure 30 | -- how many other POSIX functions there are that could benefit 31 | -- from this. Calls to getCurrentWorkingDirectory are extremely rare, 32 | -- so there would be little benefit here, but there may be other 33 | -- functions where these repeated 4KB allocations might trigger 34 | -- GC very quickly. 35 | marr <- PM.newPinnedByteArray sz 36 | let !(Ptr addr) = PM.mutableByteArrayContents marr 37 | ptr <- c_getcwd (Ptr addr) (intToCSize sz) 38 | -- We probably want to use touch# or with# here. 39 | if ptr /= nullPtr 40 | then do 41 | strSize <- findNullByte ptr 42 | dst <- PM.newByteArray strSize 43 | PM.copyMutableByteArray dst 0 marr 0 strSize 44 | dst' <- PM.unsafeFreezeByteArray dst 45 | pure (Right dst') 46 | else do 47 | errno <- getErrno 48 | if errno == eRANGE 49 | then go (2 * sz) 50 | else fmap Left getErrno 51 | 52 | chunkOverhead :: Int 53 | chunkOverhead = 2 * PM.sizeOf (undefined :: Int) 54 | 55 | intToCSize :: Int -> CSize 56 | intToCSize = fromIntegral 57 | 58 | -- There must be a null byte present or bad things will happen. 59 | -- This will return a nonnegative number. 60 | findNullByte :: Ptr CChar -> IO Int 61 | findNullByte = go 0 62 | where 63 | go :: Int -> Ptr CChar -> IO Int 64 | go !ix !ptr = do 65 | FS.peekElemOff ptr ix >>= \case 66 | 0 -> pure ix 67 | _ -> go (ix + 1) ptr 68 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | All notable changes to this project will be documented in this file. 3 | 4 | The format is inspired by [Keep a Changelog](http://keepachangelog.com/en/1.0.0/). 5 | This changelog deviates from the recommendation by not grouping changes into 6 | added, changed, deprecated, etc. subsections. 7 | 8 | This project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). 9 | 10 | ## 0.7.3.0 -- 2025-05-28 11 | 12 | - Add support for `openat` 13 | 14 | ## 0.7.2.0 -- 2024-02-28 15 | 16 | - Add `socket` as alias for `uninterruptibleSocket`. 17 | - Add `withSocket`. 18 | - Removed `UNLIFTEDARRAYFUNCTIONS` flag and support for GHC < 9.4. 19 | 20 | ## 0.7.1.0 -- 2023-10-03 21 | 22 | - Add `uninterruptibleOpenModeUntypedFlags`. 23 | - Add `Posix.Struct.AddressInfo.Poke`. 24 | - Add `Posix.File.uninterruptibleReadMutableByteArray`. 25 | 26 | ## 0.7.0.0 -- 2023-08-30 27 | 28 | - For now, remove all of the functions that work on UnliftedArray. These 29 | will be added back later once hackage starts using GHC 9.4. They are 30 | now guarded by CPP, so if anyone was using them, build this library 31 | with the `UNLIFTEDARRAYFUNCTIONS` flag to get them back. 32 | - Add `uninterruptibleConnectPtr` for better compatibility with `network`. 33 | 34 | ## 0.6.1.0 -- 2023-08-14 35 | 36 | - Add `uninterruptibleWriteBytesCompletelyErrno` 37 | - Add `writeBytesCompletelyErrno` 38 | - Add `uninterruptibleAccept4_` 39 | 40 | ## 0.6.0.1 -- 2023-07-13 41 | 42 | - Fix mistake in header file that caused builds to fail 43 | 44 | ## 0.6.0.0 -- 2023-07-13 45 | 46 | - Use Int instead of CInt for all offsets into byte arrays 47 | 48 | ## 0.5.0.0 -- 2023-07-13 49 | 50 | - Move Linux.Systemd to systemd-api library to make docs build on hackage. 51 | 52 | ## 0.4.0.1 -- 2023-06-27 53 | 54 | - Build with GHC 9.4 55 | 56 | ## 0.4.0.0 -- 2022-12-08 57 | 58 | - Add `writeMutableByteArray` 59 | - In the 0.3.5.0 release, the major version was supposed to be bumped. 60 | This is being done now instead. 61 | 62 | ## 0.3.5.0 -- 2021-07-02 63 | 64 | - Breaking: Start using pattern synonyms for macros. 65 | - Add dedicated modules for peeking at structures. 66 | - Make compatible with GHC 8.10 by changing the way ArrayArray# is handled 67 | on the C side of the FFI. 68 | - Add `uninterruptibleSetSocketOption`. 69 | - Add socket options `SO_BINDTODEVICE` and `SO_REUSEADDR`. 70 | 71 | ## 0.3.4.0 -- 2020-03-09 72 | 73 | - Add `Posix.File` 74 | - Add lower bound for `hsc2hs` build tool 75 | 76 | ## 0.3.3.0 -- 2019-12-18 77 | 78 | - Support several POSIX message queue functions. 79 | - Support Linux systemd functions. 80 | 81 | ## 0.3.2.0 -- 2019-07-21 82 | 83 | - Add more functions. 84 | 85 | ## 0.3.1.0 -- YYYY-MM-DD 86 | 87 | - Make the test suite build again. 88 | - Add `uninterruptibleSendByteArrays`. 89 | 90 | ## 0.1.0.0 -- 2018-01-02 91 | - Initial release. 92 | - Includes a ton of sockets API stuff. 93 | - Includes the get working directory function. 94 | -------------------------------------------------------------------------------- /src/Posix/File/Types.hsc: -------------------------------------------------------------------------------- 1 | {-# language DataKinds #-} 2 | {-# language DerivingStrategies #-} 3 | {-# language DuplicateRecordFields #-} 4 | {-# language GADTSyntax #-} 5 | {-# language GeneralizedNewtypeDeriving #-} 6 | {-# language KindSignatures #-} 7 | {-# language MagicHash #-} 8 | {-# language UnboxedTuples #-} 9 | {-# language NamedFieldPuns #-} 10 | 11 | -- This is needed because hsc2hs does not currently handle ticked 12 | -- promoted data constructors correctly. 13 | {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} 14 | 15 | #include 16 | #include 17 | #include 18 | #include 19 | 20 | -- | All of the data constructors provided by this module are unsafe. 21 | -- Only use them if you really know what you are doing. 22 | module Posix.File.Types 23 | ( DescriptorFlags(..) 24 | , StatusFlags(..) 25 | , CreationFlags(..) 26 | , AccessMode(..) 27 | -- * Open Access Mode 28 | , readOnly 29 | , writeOnly 30 | , readWrite 31 | -- * File Status Flags 32 | , nonblocking 33 | , append 34 | -- * File Creation Flags 35 | , create 36 | , truncate 37 | , exclusive 38 | ) where 39 | 40 | import Prelude hiding (truncate) 41 | 42 | import Data.Bits (Bits,(.|.)) 43 | import Foreign.C.Types (CInt) 44 | 45 | -- | File Descriptor Flags 46 | newtype DescriptorFlags = DescriptorFlags CInt 47 | deriving stock (Eq) 48 | deriving newtype (Bits) 49 | 50 | -- | File Status Flags 51 | newtype StatusFlags = StatusFlags CInt 52 | deriving stock (Eq) 53 | deriving newtype (Bits) 54 | 55 | -- | File Creation Flags 56 | newtype CreationFlags = CreationFlags CInt 57 | deriving stock (Eq) 58 | deriving newtype (Bits) 59 | 60 | newtype AccessMode = AccessMode CInt 61 | deriving stock (Eq) 62 | 63 | instance Semigroup DescriptorFlags where (<>) = (.|.) 64 | instance Monoid DescriptorFlags where mempty = DescriptorFlags 0 65 | 66 | instance Semigroup CreationFlags where (<>) = (.|.) 67 | instance Monoid CreationFlags where mempty = CreationFlags 0 68 | 69 | instance Semigroup StatusFlags where (<>) = (.|.) 70 | instance Monoid StatusFlags where mempty = StatusFlags 0 71 | 72 | -- | The @O_RDONLY@ access mode. 73 | readOnly :: AccessMode 74 | readOnly = AccessMode #{const O_RDONLY} 75 | 76 | -- | The @O_WRONLY@ access mode. 77 | writeOnly :: AccessMode 78 | writeOnly = AccessMode #{const O_WRONLY} 79 | 80 | -- | The @O_RDWR@ access mode. 81 | readWrite :: AccessMode 82 | readWrite = AccessMode #{const O_RDWR} 83 | 84 | -- | The @O_NONBLOCK@ flag 85 | nonblocking :: StatusFlags 86 | nonblocking = StatusFlags #{const O_NONBLOCK} 87 | 88 | -- | The @O_APPEND@ flag 89 | append :: StatusFlags 90 | append = StatusFlags #{const O_APPEND} 91 | 92 | -- | The @O_CREAT@ flag 93 | create :: CreationFlags 94 | create = CreationFlags #{const O_CREAT} 95 | 96 | -- | The @O_TRUNC@ flag 97 | truncate :: CreationFlags 98 | truncate = CreationFlags #{const O_TRUNC} 99 | 100 | -- | The @O_EXCL@ flag 101 | exclusive :: CreationFlags 102 | exclusive = CreationFlags #{const O_EXCL} 103 | -------------------------------------------------------------------------------- /include/custom.h: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | // This include file lets us use hsc2hs to generate code working 4 | // with ByteArray (through Data.Primitive) instead of Ptr. 5 | 6 | // The macro FIELD_SIZEOF is defined in the linux kernel. 7 | // It is written out here for portability. 8 | #ifndef FIELD_SIZEOF 9 | #define FIELD_SIZEOF(t, f) (sizeof(((t*)0)->f)) 10 | #endif 11 | 12 | 13 | #define hsc_readByteArray(t, f) \ 14 | if ((offsetof(t,f)) % (FIELD_SIZEOF(t,f)) == 0 && (sizeof(t) % (FIELD_SIZEOF(t,f))) == 0) { \ 15 | hsc_printf ("(\\hsc_arr hsc_ix -> readByteArray hsc_arr (%ld + (hsc_ix * %ld)))", ((offsetof(t,f)) / (FIELD_SIZEOF(t,f))), (sizeof(t) / (FIELD_SIZEOF(t,f)))); \ 16 | } else { \ 17 | hsc_printf ("BAD_BYTEARRAY_ALIGNMENT"); \ 18 | } 19 | 20 | #define hsc_writeByteArray(t, f) \ 21 | if ((offsetof(t,f)) % (FIELD_SIZEOF(t,f)) == 0 && (sizeof(t) % (FIELD_SIZEOF(t,f))) == 0) { \ 22 | hsc_printf ("(\\hsc_arr hsc_ix -> writeByteArray hsc_arr (%ld + (hsc_ix * %ld)))", ((offsetof(t,f)) / (FIELD_SIZEOF(t,f))), (sizeof(t) / (FIELD_SIZEOF(t,f)))); \ 23 | } else { \ 24 | hsc_printf ("BAD_BYTEARRAY_ALIGNMENT"); \ 25 | } 26 | 27 | #define hsc_indexByteArray(t, f) \ 28 | if ((offsetof(t,f)) % (FIELD_SIZEOF(t,f)) == 0 && (sizeof(t) % (FIELD_SIZEOF(t,f))) == 0) { \ 29 | hsc_printf ("(\\hsc_arr hsc_ix -> indexByteArray hsc_arr (%ld + (hsc_ix * %ld)))", ((offsetof(t,f)) / (FIELD_SIZEOF(t,f))), (sizeof(t) / (FIELD_SIZEOF(t,f)))); \ 30 | } else { \ 31 | hsc_printf ("BAD_BYTEARRAY_ALIGNMENT"); \ 32 | } 33 | 34 | #define hsc_readByteArrayHash(t, f) \ 35 | if ((offsetof(t,f)) % (FIELD_SIZEOF(t,f)) == 0 && (sizeof(t) % (FIELD_SIZEOF(t,f))) == 0) { \ 36 | hsc_printf ("(\\hsc_arr hsc_ix -> readByteArray# hsc_arr (%ld# +# (hsc_ix *# %ld#)))", ((offsetof(t,f)) / (FIELD_SIZEOF(t,f))), (sizeof(t) / (FIELD_SIZEOF(t,f)))); \ 37 | } else { \ 38 | hsc_printf ("BAD_BYTEARRAY_ALIGNMENT"); \ 39 | } 40 | 41 | #define hsc_writeByteArrayHash(t, f) \ 42 | if ((offsetof(t,f)) % (FIELD_SIZEOF(t,f)) == 0 && (sizeof(t) % (FIELD_SIZEOF(t,f))) == 0) { \ 43 | hsc_printf ("(\\hsc_arr hsc_ix -> writeByteArray# hsc_arr (%ld# +# (hsc_ix *# %ld#)))", ((offsetof(t,f)) / (FIELD_SIZEOF(t,f))), (sizeof(t) / (FIELD_SIZEOF(t,f)))); \ 44 | } else { \ 45 | hsc_printf ("BAD_BYTEARRAY_ALIGNMENT"); \ 46 | } 47 | 48 | #define hsc_indexByteArrayHash(t, f) \ 49 | if ((offsetof(t,f)) % (FIELD_SIZEOF(t,f)) == 0 && (sizeof(t) % (FIELD_SIZEOF(t,f))) == 0) { \ 50 | hsc_printf ("(\\hsc_arr hsc_ix -> indexByteArray# hsc_arr (%ld# +# (hsc_ix *# %ld#)))", ((offsetof(t,f)) / (FIELD_SIZEOF(t,f))), (sizeof(t) / (FIELD_SIZEOF(t,f)))); \ 51 | } else { \ 52 | hsc_printf ("BAD_BYTEARRAY_ALIGNMENT"); \ 53 | } 54 | 55 | #define hsc_readOffAddrHash(t, f) \ 56 | if ((offsetof(t,f)) % (FIELD_SIZEOF(t,f)) == 0 && (sizeof(t) % (FIELD_SIZEOF(t,f))) == 0) { \ 57 | hsc_printf ("(\\hsc_arr hsc_ix -> readOffAddr# hsc_arr (%ld# +# (hsc_ix *# %ld#)))", ((offsetof(t,f)) / (FIELD_SIZEOF(t,f))), (sizeof(t) / (FIELD_SIZEOF(t,f)))); \ 58 | } else { \ 59 | hsc_printf ("BAD_BYTEARRAY_ALIGNMENT"); \ 60 | } 61 | 62 | #define hsc_writeOffAddrHash(t, f) \ 63 | if ((offsetof(t,f)) % (FIELD_SIZEOF(t,f)) == 0 && (sizeof(t) % (FIELD_SIZEOF(t,f))) == 0) { \ 64 | hsc_printf ("(\\hsc_arr hsc_ix -> writeOffAddr# hsc_arr (%ld# +# (hsc_ix *# %ld#)))", ((offsetof(t,f)) / (FIELD_SIZEOF(t,f))), (sizeof(t) / (FIELD_SIZEOF(t,f)))); \ 65 | } else { \ 66 | hsc_printf ("BAD_BYTEARRAY_ALIGNMENT"); \ 67 | } 68 | 69 | #define hsc_indexOffAddrHash(t, f) \ 70 | if ((offsetof(t,f)) % (FIELD_SIZEOF(t,f)) == 0 && (sizeof(t) % (FIELD_SIZEOF(t,f))) == 0) { \ 71 | hsc_printf ("(\\hsc_arr hsc_ix -> indexOffAddr# hsc_arr (%ld# +# (hsc_ix *# %ld#)))", ((offsetof(t,f)) / (FIELD_SIZEOF(t,f))), (sizeof(t) / (FIELD_SIZEOF(t,f)))); \ 72 | } else { \ 73 | hsc_printf ("BAD_BYTEARRAY_ALIGNMENT"); \ 74 | } 75 | -------------------------------------------------------------------------------- /src/Posix/MessageQueue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE MagicHash #-} 3 | {-# LANGUAGE UnliftedFFITypes #-} 4 | 5 | module Posix.MessageQueue 6 | ( open 7 | , uninterruptibleReceiveByteArray 8 | , uninterruptibleSendBytes 9 | 10 | -- * Types 11 | , AccessMode (..) 12 | , CreationFlags (..) 13 | , StatusFlags (..) 14 | 15 | -- * Open Access Mode 16 | , F.readOnly 17 | , F.writeOnly 18 | , F.readWrite 19 | 20 | -- * Open Flags 21 | , F.nonblocking 22 | ) where 23 | 24 | import qualified Control.Monad.Primitive as PM 25 | import Data.Bits ((.|.)) 26 | import Data.Bytes.Types (Bytes (Bytes)) 27 | import Data.Primitive (ByteArray (..), MutableByteArray (..)) 28 | import qualified Data.Primitive as PM 29 | import Foreign.C.Error (Errno, getErrno) 30 | import Foreign.C.String (CString) 31 | import Foreign.C.Types (CInt (..), CSize (..), CUInt (..)) 32 | import GHC.Exts (Addr#, ByteArray#, Int (I#), MutableByteArray#, RealWorld) 33 | import qualified GHC.Exts as Exts 34 | import Posix.File.Types (AccessMode (..), CreationFlags (..), StatusFlags (..)) 35 | import qualified Posix.File.Types as F 36 | import System.Posix.Types (CSsize (..), Fd (..)) 37 | 38 | foreign import ccall unsafe "mqueue.h mq_receive" 39 | c_unsafe_mq_receive :: 40 | Fd -> 41 | MutableByteArray# RealWorld -> 42 | CSize -> 43 | Addr# -> 44 | IO CSsize 45 | 46 | foreign import ccall unsafe "mqueue.h mq_send_offset" 47 | c_unsafe_mq_send_offset :: 48 | Fd -> 49 | ByteArray# -> 50 | Int -> 51 | CSize -> 52 | CUInt -> 53 | IO CInt 54 | 55 | foreign import ccall safe "mqueue.h mq_open" 56 | c_safe_mq_open :: CString -> CInt -> IO Fd 57 | 58 | open :: 59 | -- | NULL-terminated name of queue, must start with slash 60 | CString -> 61 | -- | Access mode 62 | AccessMode -> 63 | -- | Creation flags 64 | CreationFlags -> 65 | -- | Status flags 66 | StatusFlags -> 67 | IO (Either Errno Fd) 68 | open !name (AccessMode x) (CreationFlags y) (StatusFlags z) = 69 | c_safe_mq_open name (x .|. y .|. z) >>= errorsFromFd 70 | 71 | uninterruptibleReceiveByteArray :: 72 | -- | Message queue 73 | Fd -> 74 | -- | Maximum length of message 75 | CSize -> 76 | IO (Either Errno ByteArray) 77 | uninterruptibleReceiveByteArray !fd !len = do 78 | m@(MutableByteArray m#) <- PM.newByteArray (csizeToInt len) 79 | r <- c_unsafe_mq_receive fd m# len Exts.nullAddr# 80 | case r of 81 | (-1) -> fmap Left getErrno 82 | _ -> do 83 | let sz = cssizeToInt r 84 | shrinkMutableByteArray m sz 85 | a <- PM.unsafeFreezeByteArray m 86 | pure (Right a) 87 | 88 | uninterruptibleSendBytes :: 89 | -- | Message queue 90 | Fd -> 91 | -- | Message 92 | Bytes -> 93 | -- | Priority 94 | CUInt -> 95 | IO (Either Errno ()) 96 | uninterruptibleSendBytes !fd (Bytes (ByteArray arr) off len) pri = 97 | c_unsafe_mq_send_offset fd arr off (intToCSize len) pri 98 | >>= errorsFromInt_ 99 | 100 | shrinkMutableByteArray :: MutableByteArray RealWorld -> Int -> IO () 101 | shrinkMutableByteArray (MutableByteArray arr) (I# sz) = 102 | PM.primitive_ (Exts.shrinkMutableByteArray# arr sz) 103 | 104 | cssizeToInt :: CSsize -> Int 105 | cssizeToInt = fromIntegral 106 | 107 | csizeToInt :: CSize -> Int 108 | csizeToInt = fromIntegral 109 | 110 | intToCSize :: Int -> CSize 111 | intToCSize = fromIntegral 112 | 113 | -- Sometimes, functions that return an int use zero to indicate 114 | -- success and negative one to indicate failure without including 115 | -- additional information in the value. 116 | errorsFromInt_ :: CInt -> IO (Either Errno ()) 117 | errorsFromInt_ r = 118 | if r == 0 119 | then pure (Right ()) 120 | else fmap Left getErrno 121 | 122 | errorsFromFd :: Fd -> IO (Either Errno Fd) 123 | errorsFromFd r = 124 | if r > (-1) 125 | then pure (Right r) 126 | else fmap Left getErrno 127 | -------------------------------------------------------------------------------- /src/Linux/Socket.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE MagicHash #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE UnliftedFFITypes #-} 7 | 8 | module Linux.Socket 9 | ( -- * Functions 10 | uninterruptibleAccept4 11 | , uninterruptibleAccept4_ 12 | 13 | -- * Types 14 | , SocketFlags (..) 15 | 16 | -- * Option Names 17 | , LST.headerInclude 18 | 19 | -- * Message Flags 20 | , LST.dontWait 21 | , LST.truncate 22 | , LST.controlTruncate 23 | 24 | -- * Socket Flags 25 | , LST.closeOnExec 26 | , LST.nonblocking 27 | 28 | -- * Twiddle 29 | , applySocketFlags 30 | 31 | -- * UDP Header 32 | , LST.sizeofUdpHeader 33 | , LST.pokeUdpHeaderSourcePort 34 | , LST.pokeUdpHeaderDestinationPort 35 | , LST.pokeUdpHeaderLength 36 | , LST.pokeUdpHeaderChecksum 37 | 38 | -- * IPv4 Header 39 | , LST.sizeofIpHeader 40 | , LST.pokeIpHeaderVersionIhl 41 | , LST.pokeIpHeaderTypeOfService 42 | , LST.pokeIpHeaderTotalLength 43 | , LST.pokeIpHeaderIdentifier 44 | , LST.pokeIpHeaderFragmentOffset 45 | , LST.pokeIpHeaderTimeToLive 46 | , LST.pokeIpHeaderProtocol 47 | , LST.pokeIpHeaderChecksum 48 | , LST.pokeIpHeaderSourceAddress 49 | , LST.pokeIpHeaderDestinationAddress 50 | ) where 51 | 52 | import Prelude hiding (truncate) 53 | 54 | import Data.Bits ((.|.)) 55 | import Data.Primitive (MutableByteArray (..)) 56 | import Data.Void (Void) 57 | import Foreign.C.Error (Errno, getErrno) 58 | import Foreign.C.Types (CInt (..)) 59 | import Foreign.Ptr (nullPtr) 60 | import GHC.Exts (Int (I#), MutableByteArray#, Ptr (..), RealWorld, shrinkMutableByteArray#) 61 | import Linux.Socket.Types (SocketFlags (..)) 62 | import Posix.Socket (SocketAddress (..), Type (..)) 63 | import System.Posix.Types (Fd (..)) 64 | 65 | import qualified Control.Monad.Primitive as PM 66 | import qualified Data.Primitive as PM 67 | import qualified Linux.Socket.Types as LST 68 | 69 | foreign import ccall unsafe "sys/socket.h accept4" 70 | c_unsafe_accept4 :: 71 | Fd -> 72 | MutableByteArray# RealWorld -> -- SocketAddress 73 | MutableByteArray# RealWorld -> -- Ptr CInt 74 | SocketFlags -> 75 | IO Fd 76 | 77 | -- Variant of c_unsafe_ptr_accept4 that uses Ptr instead of MutableByteArray. 78 | -- Currently, we expect that the two pointers are set to NULL. 79 | -- This is only used internally. 80 | foreign import ccall unsafe "sys/socket.h accept4" 81 | c_unsafe_ptr_accept4 :: 82 | Fd -> 83 | Ptr Void -> -- SocketAddress 84 | Ptr Void -> -- Ptr CInt 85 | SocketFlags -> 86 | IO Fd 87 | 88 | {- | Linux extends the @type@ argument of 89 | to allow 90 | setting two socket flags on socket creation: @SOCK_CLOEXEC@ and 91 | @SOCK_NONBLOCK@. It is advisable to set @SOCK_CLOEXEC@ on when 92 | opening a socket on linux. For example, we may open a TCP Internet 93 | socket with: 94 | 95 | > uninterruptibleSocket internet (applySocketFlags closeOnExec stream) defaultProtocol 96 | 97 | To additionally open the socket in nonblocking mode 98 | (e.g. with @SOCK_NONBLOCK@): 99 | 100 | > uninterruptibleSocket internet (applySocketFlags (closeOnExec <> nonblocking) stream) defaultProtocol 101 | -} 102 | applySocketFlags :: SocketFlags -> Type -> Type 103 | applySocketFlags (SocketFlags s) (Type t) = Type (s .|. t) 104 | 105 | shrinkMutableByteArray :: MutableByteArray RealWorld -> Int -> IO () 106 | shrinkMutableByteArray (MutableByteArray arr) (I# sz) = 107 | PM.primitive_ (shrinkMutableByteArray# arr sz) 108 | 109 | {- | Variant of 'Posix.Socket.uninterruptibleAccept' that allows setting 110 | flags on the newly-accepted connection. 111 | -} 112 | uninterruptibleAccept4 :: 113 | -- | Listening socket 114 | Fd -> 115 | -- | Maximum socket address size 116 | CInt -> 117 | -- | Set non-blocking and close-on-exec without extra syscall 118 | SocketFlags -> 119 | -- | Peer information and connected socket 120 | IO (Either Errno (CInt, SocketAddress, Fd)) 121 | {-# INLINE uninterruptibleAccept4 #-} 122 | uninterruptibleAccept4 !sock !maxSz !flags = do 123 | sockAddrBuf@(MutableByteArray sockAddrBuf#) <- PM.newByteArray (cintToInt maxSz) 124 | lenBuf@(MutableByteArray lenBuf#) <- PM.newByteArray (PM.sizeOf (undefined :: CInt)) 125 | PM.writeByteArray lenBuf 0 maxSz 126 | r <- c_unsafe_accept4 sock sockAddrBuf# lenBuf# flags 127 | if r > (-1) 128 | then do 129 | (sz :: CInt) <- PM.readByteArray lenBuf 0 130 | if sz < maxSz 131 | then shrinkMutableByteArray sockAddrBuf (cintToInt sz) 132 | else pure () 133 | sockAddr <- PM.unsafeFreezeByteArray sockAddrBuf 134 | pure (Right (sz, SocketAddress sockAddr, r)) 135 | else fmap Left getErrno 136 | 137 | {- | Variant of 'uninterruptibleAccept4' that requests that the kernel not 138 | include the socket address in its reponse. 139 | -} 140 | uninterruptibleAccept4_ :: 141 | -- | Listening socket 142 | Fd -> 143 | -- | Set non-blocking and close-on-exec without extra syscall 144 | SocketFlags -> 145 | -- | Connected socket 146 | IO (Either Errno Fd) 147 | {-# INLINE uninterruptibleAccept4_ #-} 148 | uninterruptibleAccept4_ !sock !flags = do 149 | r <- c_unsafe_ptr_accept4 sock nullPtr nullPtr flags 150 | if r > (-1) 151 | then pure (Right r) 152 | else fmap Left getErrno 153 | 154 | cintToInt :: CInt -> Int 155 | cintToInt = fromIntegral 156 | -------------------------------------------------------------------------------- /src/Posix/Poll/Types.hsc: -------------------------------------------------------------------------------- 1 | {-# language BangPatterns #-} 2 | {-# language BinaryLiterals #-} 3 | {-# language DataKinds #-} 4 | {-# language DerivingStrategies #-} 5 | {-# language DuplicateRecordFields #-} 6 | {-# language GADTSyntax #-} 7 | {-# language GeneralizedNewtypeDeriving #-} 8 | {-# language KindSignatures #-} 9 | {-# language NamedFieldPuns #-} 10 | {-# language TypeApplications #-} 11 | {-# language MagicHash #-} 12 | {-# language UnboxedTuples #-} 13 | {-# language PolyKinds #-} 14 | {-# language DataKinds #-} 15 | 16 | -- This is needed because hsc2hs does not currently handle ticked 17 | -- promoted data constructors correctly. 18 | {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} 19 | 20 | #define _GNU_SOURCE 21 | #include 22 | #include "custom.h" 23 | 24 | -- | All of the data constructors provided by this module are unsafe. 25 | -- Only use them if you really know what you are doing. 26 | module Posix.Poll.Types 27 | ( PollFd(..) 28 | , Exchange(..) 29 | , input 30 | , output 31 | , error 32 | , hangup 33 | , invalid 34 | , isSubeventOf 35 | ) where 36 | 37 | import Prelude hiding (truncate,error) 38 | 39 | import Data.Bits ((.|.),(.&.)) 40 | import Data.Primitive (Prim(..)) 41 | import Foreign.C.Types (CInt(..),CShort) 42 | import Foreign.Storable (Storable(..)) 43 | import GHC.Exts (Int(I##),Int##,(+##),(*##)) 44 | import System.Posix.Types (Fd(..)) 45 | 46 | import qualified Data.Kind 47 | import qualified Data.Primitive as PM 48 | 49 | data PollFd = PollFd 50 | { descriptor :: !Fd 51 | -- ^ The @fd@ field of @struct pollfd@ 52 | , request :: !(Event Request) 53 | -- ^ The @events@ field of @struct pollfd@ 54 | , response :: !(Event Response) 55 | -- ^ The @revents@ field of @struct pollfd@ 56 | } 57 | 58 | newtype Event :: Exchange -> Data.Kind.Type where 59 | Event :: CShort -> Event e 60 | deriving newtype (Eq,Storable,Prim) 61 | 62 | instance Semigroup (Event e) where 63 | Event a <> Event b = Event (a .|. b) 64 | 65 | instance Monoid (Event e) where 66 | mempty = Event 0 67 | 68 | data Exchange = Request | Response 69 | 70 | instance Storable PollFd where 71 | sizeOf _ = #{size struct pollfd} 72 | alignment _ = alignment (undefined :: CInt) 73 | peek ptr = do 74 | descriptor <- #{peek struct pollfd, fd} ptr 75 | request <- #{peek struct pollfd, events} ptr 76 | response <- #{peek struct pollfd, revents} ptr 77 | let !pollfd = PollFd{descriptor,request,response} 78 | pure pollfd 79 | poke ptr PollFd{descriptor,request,response} = do 80 | #{poke struct pollfd, fd} ptr descriptor 81 | #{poke struct pollfd, events} ptr request 82 | #{poke struct pollfd, revents} ptr response 83 | 84 | unI :: Int -> Int## 85 | unI (I## i) = i 86 | 87 | instance Prim PollFd where 88 | sizeOf## _ = unI #{size struct pollfd} 89 | alignment## _ = alignment## (undefined :: CInt) 90 | indexByteArray## arr i = PollFd 91 | { descriptor = #{indexByteArrayHash struct pollfd, fd} arr i 92 | , request = #{indexByteArrayHash struct pollfd, events} arr i 93 | , response = #{indexByteArrayHash struct pollfd, revents} arr i 94 | } 95 | writeByteArray## arr i PollFd{descriptor,request,response} s0 = case #{writeByteArrayHash struct pollfd, fd} arr i descriptor s0 of 96 | s1 -> case #{writeByteArrayHash struct pollfd, events} arr i request s1 of 97 | s2 -> #{writeByteArrayHash struct pollfd, revents} arr i response s2 98 | readByteArray## arr i s0 = case #{readByteArrayHash struct pollfd, fd} arr i s0 of 99 | (## s1, descriptor ##) -> case #{readByteArrayHash struct pollfd, events} arr i s1 of 100 | (## s2, request ##) -> case #{readByteArrayHash struct pollfd, revents} arr i s2 of 101 | (## s3, response ##) -> (## s3, PollFd{descriptor,request,response} ##) 102 | setByteArray## = PM.defaultSetByteArray## 103 | indexOffAddr## arr i = PollFd 104 | { descriptor = #{indexOffAddrHash struct pollfd, fd} arr i 105 | , request = #{indexOffAddrHash struct pollfd, events} arr i 106 | , response = #{indexOffAddrHash struct pollfd, revents} arr i 107 | } 108 | writeOffAddr## arr i PollFd{descriptor,request,response} s0 = case #{writeOffAddrHash struct pollfd, fd} arr i descriptor s0 of 109 | s1 -> case #{writeOffAddrHash struct pollfd, events} arr i request s1 of 110 | s2 -> #{writeOffAddrHash struct pollfd, revents} arr i response s2 111 | readOffAddr## arr i s0 = case #{readOffAddrHash struct pollfd, fd} arr i s0 of 112 | (## s1, fdVal ##) -> case #{readOffAddrHash struct pollfd, events} arr i s1 of 113 | (## s2, eventsVal ##) -> case #{readOffAddrHash struct pollfd, revents} arr i s2 of 114 | (## s3, reventsVal ##) -> (## s3, PollFd fdVal eventsVal reventsVal ##) 115 | setOffAddr## = PM.defaultSetOffAddr## 116 | 117 | -- | The @POLLIN@ event. 118 | input :: Event e 119 | input = Event #{const POLLIN} 120 | 121 | -- | The @POLLOUT@ event. 122 | output :: Event e 123 | output = Event #{const POLLOUT} 124 | 125 | -- | The @POLLERR@ event. 126 | error :: Event Response 127 | error = Event #{const POLLERR} 128 | 129 | -- | The @POLLHUP@ event. 130 | hangup :: Event Response 131 | hangup = Event #{const POLLHUP} 132 | 133 | -- | The @POLLNVAL@ event. 134 | invalid :: Event Response 135 | invalid = Event #{const POLLNVAL} 136 | 137 | -- | Is the first argument a subset of the second argument? 138 | isSubeventOf :: Event e -> Event e -> Bool 139 | isSubeventOf (Event a) (Event b) = a .&. b == a 140 | -------------------------------------------------------------------------------- /src/Foreign/C/String/Managed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE MagicHash #-} 5 | {-# LANGUAGE MultiWayIf #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE UnboxedTuples #-} 9 | 10 | module Foreign.C.String.Managed 11 | ( ManagedCString (..) 12 | , terminated 13 | , terminatedU 14 | , unterminated 15 | , fromBytes 16 | , fromText 17 | , fromLatinString 18 | , fromShortText 19 | , pinnedFromBytes 20 | , pin 21 | , touch 22 | , contents 23 | ) where 24 | 25 | import Control.Monad.ST (ST) 26 | import Control.Monad.ST.Run (runByteArrayST) 27 | import Data.Bytes.Types (Bytes (Bytes)) 28 | import Data.Char (ord) 29 | import Data.Primitive (ByteArray (..), MutableByteArray) 30 | import Data.Text (Text) 31 | import Data.Text.Short (ShortText) 32 | import Data.Word (Word8) 33 | import Foreign.C.String (CString) 34 | import Foreign.Ptr (castPtr) 35 | import GHC.Exts (ByteArray#, Char (C#), Int (I#), chr#, touch#) 36 | import GHC.IO (IO (IO)) 37 | 38 | import qualified Data.Bytes as Bytes 39 | import qualified Data.Bytes.Text.Utf8 as Utf8 40 | import qualified Data.Primitive as PM 41 | import qualified GHC.Exts as Exts 42 | 43 | -- | An unsliced byte sequence with @NUL@ as the final byte. 44 | newtype ManagedCString = ManagedCString ByteArray 45 | deriving newtype (Eq) 46 | 47 | instance Semigroup ManagedCString where 48 | ManagedCString a <> ManagedCString b = ManagedCString $ runByteArrayST $ do 49 | let lenA = PM.sizeofByteArray a 50 | let lenB = PM.sizeofByteArray b 51 | dst <- PM.newByteArray (lenA + lenB - 1) 52 | PM.copyByteArray dst 0 a 0 (lenA - 1) 53 | PM.copyByteArray dst (lenA - 1) b 0 lenB 54 | PM.unsafeFreezeByteArray dst 55 | 56 | instance Monoid ManagedCString where 57 | mempty = ManagedCString $ runByteArrayST $ do 58 | dst <- PM.newByteArray 1 59 | PM.writeByteArray dst 0 (0 :: Word8) 60 | PM.unsafeFreezeByteArray dst 61 | 62 | instance Exts.IsString ManagedCString where 63 | fromString = fromLatinString 64 | 65 | instance Show ManagedCString where 66 | showsPrec _ (ManagedCString arr) s0 = 67 | PM.foldrByteArray 68 | ( \(w :: Word8) s -> 69 | if 70 | | w == 0 -> s 71 | | w < 32 -> '?' : s 72 | | w > 126 -> '?' : s 73 | | otherwise -> case fromIntegral @Word8 @Int w of 74 | I# i -> C# (chr# i) : s 75 | ) 76 | s0 77 | arr 78 | 79 | terminatedU :: ManagedCString -> ByteArray 80 | terminatedU (ManagedCString x) = x 81 | 82 | terminated :: ManagedCString -> Bytes 83 | terminated (ManagedCString x) = Bytes.fromByteArray x 84 | 85 | unterminated :: ManagedCString -> Bytes 86 | unterminated (ManagedCString x) = Bytes x 0 (PM.sizeofByteArray x - 1) 87 | 88 | fromShortText :: ShortText -> ManagedCString 89 | fromShortText !ts = fromBytes (Utf8.fromShortText ts) 90 | 91 | fromText :: Text -> ManagedCString 92 | fromText = fromBytes . Utf8.fromText 93 | 94 | -- | Copies the slice, appending a @NUL@ byte to the end. 95 | fromBytes :: Bytes -> ManagedCString 96 | fromBytes (Bytes arr off len) = ManagedCString $ runByteArrayST $ do 97 | dst <- PM.newByteArray (len + 1) 98 | PM.copyByteArray dst 0 arr off len 99 | PM.writeByteArray dst len (0 :: Word8) 100 | PM.unsafeFreezeByteArray dst 101 | 102 | -- | Copies the slice into pinned memory, appending a @NUL@ byte to the end. 103 | pinnedFromBytes :: Bytes -> ManagedCString 104 | pinnedFromBytes (Bytes arr off len) = ManagedCString $ runByteArrayST $ do 105 | dst <- PM.newPinnedByteArray (len + 1) 106 | PM.copyByteArray dst 0 arr off len 107 | PM.writeByteArray dst len (0 :: Word8) 108 | PM.unsafeFreezeByteArray dst 109 | 110 | pin :: ManagedCString -> ManagedCString 111 | pin (ManagedCString x) = 112 | if PM.isByteArrayPinned x 113 | then ManagedCString x 114 | else ManagedCString $ runByteArrayST $ do 115 | let len = PM.sizeofByteArray x 116 | dst <- PM.newPinnedByteArray len 117 | PM.copyByteArray dst 0 x 0 len 118 | PM.unsafeFreezeByteArray dst 119 | 120 | touch :: ManagedCString -> IO () 121 | touch (ManagedCString (ByteArray x)) = touchByteArray# x 122 | 123 | touchByteArray# :: ByteArray# -> IO () 124 | touchByteArray# x = IO $ \s -> case touch# x s of s' -> (# s', () #) 125 | 126 | {- | Convert a 'String' consisting of only characters representable 127 | by ISO-8859-1. These are encoded with ISO-8859-1. Any character 128 | with a codepoint above @U+00FF@ is replaced by an unspecified byte. 129 | -} 130 | fromLatinString :: String -> ManagedCString 131 | {-# NOINLINE fromLatinString #-} 132 | fromLatinString str = ManagedCString $ runByteArrayST $ do 133 | let lenPred0 = 63 134 | dst0 <- PM.newByteArray (lenPred0 + 1) 135 | go str dst0 0 lenPred0 136 | where 137 | go :: forall s. String -> MutableByteArray s -> Int -> Int -> ST s ByteArray 138 | go [] !dst !ix !_ = do 139 | PM.writeByteArray dst ix (0 :: Word8) 140 | PM.resizeMutableByteArray dst (ix + 1) >>= PM.unsafeFreezeByteArray 141 | go (c : cs) !dst !ix !lenPred = 142 | if ix < lenPred 143 | then do 144 | PM.writeByteArray dst ix (fromIntegral @Int @Word8 (ord c)) 145 | go cs dst (ix + 1) lenPred 146 | else do 147 | let nextLenPred = lenPred * 2 148 | dst' <- PM.newByteArray (nextLenPred + 1) 149 | PM.copyMutableByteArray dst' 0 dst 0 ix 150 | PM.writeByteArray dst' ix (fromIntegral @Int @Word8 (ord c)) 151 | go cs dst' (ix + 1) nextLenPred 152 | 153 | {- | Get a pointer to the payload of the managed C string. The behavior is 154 | undefined if the argument is not pinned. 155 | -} 156 | contents :: ManagedCString -> CString 157 | contents (ManagedCString x) = castPtr (PM.byteArrayContents x) 158 | -------------------------------------------------------------------------------- /posix-api.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: posix-api 3 | version: 0.7.3.0 4 | synopsis: posix bindings 5 | description: 6 | This library provides a very thin wrapper around POSIX APIs. It can be 7 | compiled on any operating system that implements the standard as specified 8 | in 9 | faithfully. It has similar goals as the `unix` package, but its design 10 | differs in several areas: 11 | . 12 | * `ByteArray` and `Addr` are used pervasively. There is no use of 13 | `String` in this library. 14 | . 15 | * Functions do not throw errors. This library uses `IO (Either Errno a)` 16 | in places where `unix` would use `IO a`. 17 | . 18 | * The numeric types from `Foreign.C.Types` and `System.Posix.Types` are 19 | used in the type signatures of functions so that a haskell function's 20 | type signature matches its underlying POSIX equivalent exactly. 21 | . 22 | * Flags are newtypes over `CInt` (or whatever integral type matches the 23 | posix specification) rather than enumerations. The data constructors 24 | are exported, making the types extensible for operating system that 25 | have additional flags. 26 | . 27 | About a dozen other packages offers wrappers for some subset of the POSIX 28 | specification are strewn across hackage. They include `regex-posix`, 29 | `posix-paths`, `posix-timer`, `posix-socket`, `posix-filelock`, 30 | `posix-acl`, etc. This library differs from all off these in various 31 | ways. Here are some of the design guidelines followed here that distinguish 32 | this package from some or all of these others: 33 | . 34 | * Scope. Although this library does not include all APIs specified by 35 | POSIX, it welcomes as many of them as anyone is willing to implement. 36 | . 37 | * Monomorphization. Effectful functions in this library return their 38 | results in `IO` rather than using a type that involves `MonadIO` 39 | or `MonadBaseControl`. 40 | . 41 | * Typeclass avoidance. This library does not introduce new typeclasses. 42 | Overloading is eschewed in favor of providing multiple functions 43 | with distinct names. 44 | . 45 | * Minimality. Functions wrapping the POSIX APIs do little more than 46 | wrap the underlying functions. The major deviation here is that, 47 | when applicable, the wrappers allocate buffers are the underlying 48 | functions fill. This eschews C's characteristic buffer-passing 49 | in favor of the Haskell convention of allocating internally and returning. 50 | A more minor deviation is that for safe FFI calls, this library 51 | will perform additional work to ensure that only pinned byte arrays are 52 | handed over. 53 | . 54 | Unlike `network`, this sockets API in this library does not integrate 55 | sockets with GHC's event manager. This is geared 56 | toward an audience that understands how to use `threadWaitRead` 57 | and `threadWaitWrite` with unsafe FFI calls to avoid blocking 58 | the runtime. 59 | 60 | homepage: https://github.com/byteverse/posix-api 61 | bug-reports: https://github.com/byteverse/posix-api/issues 62 | license: BSD-3-Clause 63 | license-file: LICENSE 64 | author: Andrew Martin 65 | maintainer: amartin@layer3com.com 66 | copyright: 2018 Andrew Martin 67 | category: System 68 | build-type: Simple 69 | extra-source-files: 70 | cbits/HaskellPosix.c 71 | include/custom.h 72 | include/HaskellPosix.h 73 | 74 | extra-doc-files: 75 | CHANGELOG.md 76 | README.md 77 | 78 | tested-with: GHC ==9.4.8 || ==9.6.3 || ==9.8.1 79 | 80 | flag assertions 81 | manual: True 82 | description: Extra run-time invariant checking 83 | default: False 84 | 85 | common build-settings 86 | default-language: Haskell2010 87 | ghc-options: -Wall -Wunused-packages 88 | 89 | library 90 | import: build-settings 91 | exposed-modules: 92 | Foreign.C.String.Managed 93 | Linux.Epoll 94 | Linux.MessageQueue 95 | Linux.Socket 96 | Posix.Directory 97 | Posix.File 98 | Posix.MessageQueue 99 | Posix.Poll 100 | Posix.Select 101 | Posix.Socket 102 | Posix.Struct.AddressInfo.Peek 103 | Posix.Struct.AddressInfo.Poke 104 | Posix.Struct.SocketAddressInternet.Peek 105 | Posix.Types 106 | 107 | other-modules: 108 | Assertion 109 | Linux.Epoll.Types 110 | Linux.MessageQueue.Types 111 | Linux.Socket.Types 112 | Posix.File.Types 113 | Posix.MessageQueue.Types 114 | Posix.Poll.Types 115 | Posix.Socket.Platform 116 | Posix.Socket.Types 117 | 118 | build-depends: 119 | , base >=4.16.3 && <5 120 | , byte-order >=0.1.2 && <0.2 121 | , byteslice >=0.2.10 && <0.3 122 | , primitive >=0.9 && <0.10 123 | , primitive-addr >=0.1 && <0.2 124 | , primitive-offset >=0.2 && <0.3 125 | , run-st >=0.1.1 && <0.2 126 | , text-short >=0.1.5 127 | , text >=2.1 128 | 129 | hs-source-dirs: src 130 | 131 | if flag(assertions) 132 | hs-source-dirs: src-assertions 133 | 134 | else 135 | hs-source-dirs: src-noassertions 136 | 137 | if os(linux) 138 | hs-source-dirs: src-linux 139 | 140 | ghc-options: -O2 141 | c-sources: cbits/HaskellPosix.c 142 | include-dirs: include 143 | includes: HaskellPosix.h 144 | build-tool-depends: hsc2hs:hsc2hs >=0.68.5 145 | 146 | test-suite test 147 | import: build-settings 148 | type: exitcode-stdio-1.0 149 | hs-source-dirs: test 150 | main-is: Main.hs 151 | build-depends: 152 | , base 153 | , posix-api 154 | , primitive >=0.7 155 | , tasty 156 | , tasty-hunit 157 | 158 | ghc-options: -threaded 159 | 160 | source-repository head 161 | type: git 162 | location: git://github.com/byteverse/posix-api.git 163 | -------------------------------------------------------------------------------- /src/Linux/Epoll.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE GADTSyntax #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE MagicHash #-} 6 | {-# LANGUAGE UnliftedFFITypes #-} 7 | 8 | module Linux.Epoll 9 | ( -- * Functions 10 | 11 | -- ** Create 12 | uninterruptibleCreate 13 | , uninterruptibleCreate1 14 | 15 | -- ** Wait 16 | , waitMutablePrimArray 17 | , uninterruptibleWaitMutablePrimArray 18 | 19 | -- ** Control 20 | , uninterruptibleControlMutablePrimArray 21 | 22 | -- * Types 23 | , EpollFlags (..) 24 | , ControlOperation (..) 25 | , Events (..) 26 | , Event (..) 27 | , Exchange (..) 28 | 29 | -- * Classes 30 | , PrimEpollData 31 | 32 | -- * Constants 33 | , T.closeOnExec 34 | , T.add 35 | , T.modify 36 | , T.delete 37 | , T.input 38 | , T.output 39 | , T.priority 40 | , T.hangup 41 | , T.readHangup 42 | , T.error 43 | , T.edgeTriggered 44 | 45 | -- * Events Combinators 46 | , T.containsAnyEvents 47 | , T.containsAllEvents 48 | 49 | -- * Marshalling 50 | , T.sizeofEvent 51 | , T.peekEventEvents 52 | , T.peekEventDataFd 53 | , T.peekEventDataPtr 54 | , T.peekEventDataU32 55 | , T.peekEventDataU64 56 | , T.pokeEventDataU64 57 | ) where 58 | 59 | import Prelude hiding (error) 60 | 61 | import Assertion (assertMutablePrimArrayPinned) 62 | import Data.Primitive (MutablePrimArray (..)) 63 | import Foreign.C.Error (Errno, getErrno) 64 | import Foreign.C.Types (CInt (..)) 65 | import GHC.Exts (MutableByteArray#, RealWorld) 66 | import Linux.Epoll.Types (ControlOperation (..), EpollFlags (..), Event (..), Events (..), Exchange (..), PrimEpollData (..)) 67 | import System.Posix.Types (Fd (..)) 68 | 69 | import qualified Linux.Epoll.Types as T 70 | 71 | foreign import ccall unsafe "sys/epoll.h epoll_create" 72 | c_epoll_create :: CInt -> IO Fd 73 | 74 | foreign import ccall unsafe "sys/epoll.h epoll_create1" 75 | c_epoll_create1 :: EpollFlags -> IO Fd 76 | 77 | foreign import ccall unsafe "sys/epoll.h epoll_wait" 78 | c_epoll_wait_unsafe :: Fd -> MutableByteArray# RealWorld -> CInt -> CInt -> IO CInt 79 | 80 | foreign import ccall safe "sys/epoll.h epoll_wait" 81 | c_epoll_wait_safe :: Fd -> MutableByteArray# RealWorld -> CInt -> CInt -> IO CInt 82 | 83 | foreign import ccall unsafe "sys/epoll.h epoll_ctl" 84 | c_epoll_ctl_unsafe :: Fd -> ControlOperation -> Fd -> MutableByteArray# RealWorld -> IO CInt 85 | 86 | -- -- | Write @data.u64@ from @struct epoll_event@. 87 | -- writeEventEvents :: 88 | -- MutableByteArray RealWorld 89 | -- -> Int -- ^ Index. Element are @struct epoll_event@. 90 | -- -> Events e 91 | -- -> IO () 92 | -- writeEventEvents !arr !ix !payload = do 93 | -- -- See the comments on readEventDataU64 94 | -- PM.writeByteArray arr (ix * 3 + 1) (word64ToWord32 (unsafeShiftR payload 32)) 95 | -- PM.writeByteArray arr (ix * 3 + 2) (word64ToWord32 payload) 96 | 97 | uninterruptibleCreate :: 98 | -- | Size, ignored since Linux 2.6.8 99 | CInt -> 100 | IO (Either Errno Fd) 101 | {-# INLINE uninterruptibleCreate #-} 102 | uninterruptibleCreate !sz = c_epoll_create sz >>= errorsFromFd 103 | 104 | uninterruptibleCreate1 :: 105 | -- | Flags 106 | EpollFlags -> 107 | IO (Either Errno Fd) 108 | {-# INLINE uninterruptibleCreate1 #-} 109 | uninterruptibleCreate1 !flags = 110 | c_epoll_create1 flags >>= errorsFromFd 111 | 112 | {- | Wait for an I/O event on an epoll file descriptor. The 113 | 114 | includes more details. The @timeout@ argument is omitted 115 | since it is nonsense to choose anything other than 0 when 116 | using the unsafe FFI. 117 | -} 118 | uninterruptibleWaitMutablePrimArray :: 119 | -- | EPoll file descriptor 120 | Fd -> 121 | -- | Event buffer 122 | MutablePrimArray RealWorld (Event 'Response a) -> 123 | -- | Maximum events 124 | CInt -> 125 | -- | Number of events received 126 | IO (Either Errno CInt) 127 | {-# INLINE uninterruptibleWaitMutablePrimArray #-} 128 | uninterruptibleWaitMutablePrimArray !epfd (MutablePrimArray evs) !maxEvents = 129 | c_epoll_wait_unsafe epfd evs maxEvents 0 >>= errorsFromInt 130 | 131 | {- | Wait for an I/O event on an epoll file descriptor. The 132 | 133 | includes more details. The event buffer must be a pinned 134 | byte array. 135 | -} 136 | waitMutablePrimArray :: 137 | -- | EPoll file descriptor 138 | Fd -> 139 | -- | Event buffer, must be pinned 140 | MutablePrimArray RealWorld (Event 'Response a) -> 141 | -- | Maximum events 142 | CInt -> 143 | -- | Timeout in milliseconds, use @-1@ to block forever. 144 | CInt -> 145 | -- | Number of events received 146 | IO (Either Errno CInt) 147 | {-# INLINE waitMutablePrimArray #-} 148 | waitMutablePrimArray !epfd !evs !maxEvents !timeout = 149 | let !(MutablePrimArray evs#) = assertMutablePrimArrayPinned evs 150 | in c_epoll_wait_safe epfd evs# maxEvents timeout >>= errorsFromInt 151 | 152 | {- | Add, modify, or remove entries in the interest list of the 153 | epoll instance referred to by the file descriptor @epfd@. 154 | 155 | includes more details. 156 | -} 157 | uninterruptibleControlMutablePrimArray :: 158 | -- | EPoll file descriptor (@epfd@) 159 | Fd -> 160 | -- | Operation: @EPOLL_CTL_ADD@, @EPOLL_CTL_MOD@, or @EPOLL_CTL_DEL@ 161 | ControlOperation -> 162 | -- | File descriptor whose registration will be affected 163 | Fd -> 164 | -- | A single event. This is read from, not written to. 165 | MutablePrimArray RealWorld (Event 'Request a) -> 166 | IO (Either Errno ()) 167 | {-# INLINE uninterruptibleControlMutablePrimArray #-} 168 | uninterruptibleControlMutablePrimArray !epfd !op !fd (MutablePrimArray ev) = 169 | c_epoll_ctl_unsafe epfd op fd ev >>= errorsFromInt_ 170 | 171 | errorsFromFd :: Fd -> IO (Either Errno Fd) 172 | {-# INLINE errorsFromFd #-} 173 | errorsFromFd r = 174 | if r > (-1) 175 | then pure (Right r) 176 | else fmap Left getErrno 177 | 178 | errorsFromInt :: CInt -> IO (Either Errno CInt) 179 | {-# INLINE errorsFromInt #-} 180 | errorsFromInt r = 181 | if r > (-1) 182 | then pure (Right r) 183 | else fmap Left getErrno 184 | 185 | -- Sometimes, functions that return an int use zero to indicate 186 | -- success and negative one to indicate failure without including 187 | -- additional information in the value. 188 | errorsFromInt_ :: CInt -> IO (Either Errno ()) 189 | {-# INLINE errorsFromInt_ #-} 190 | errorsFromInt_ r = 191 | if r == 0 192 | then pure (Right ()) 193 | else fmap Left getErrno 194 | -------------------------------------------------------------------------------- /src-linux/Posix/Socket/Platform.hsc: -------------------------------------------------------------------------------- 1 | {-# language BangPatterns #-} 2 | {-# language DerivingStrategies #-} 3 | {-# language DuplicateRecordFields #-} 4 | {-# language GeneralizedNewtypeDeriving #-} 5 | {-# language MagicHash #-} 6 | {-# language NamedFieldPuns #-} 7 | {-# language UnboxedTuples #-} 8 | {-# language ScopedTypeVariables #-} 9 | 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include "custom.h" 16 | 17 | module Posix.Socket.Platform 18 | ( -- * Encoding Socket Addresses 19 | encodeSocketAddressInternet 20 | , encodeSocketAddressUnix 21 | -- * Decoding Socket Addresses 22 | , decodeSocketAddressInternet 23 | , indexSocketAddressInternet 24 | -- * Sizes 25 | , sizeofSocketAddressInternet 26 | ) where 27 | 28 | import Control.Monad (when) 29 | import Data.Primitive (MutableByteArray,ByteArray(..),writeByteArray,indexByteArray) 30 | import Data.Primitive.Addr (Addr(..)) 31 | import Data.Word (Word8) 32 | import Foreign.C.Types (CUShort,CInt) 33 | import GHC.Exts (ByteArray##,State##,RealWorld,runRW##,Ptr(..)) 34 | import GHC.ST (ST(..)) 35 | import Posix.Socket.Types (SocketAddress(..)) 36 | import Posix.Socket.Types (SocketAddressInternet(..),SocketAddressUnix(..)) 37 | import Foreign.Storable (peekByteOff) 38 | 39 | import qualified Data.Primitive as PM 40 | import qualified Data.Primitive.Addr as PMA 41 | import qualified Foreign.Storable as FS 42 | 43 | -- | The size of a serialized internet socket address. 44 | sizeofSocketAddressInternet :: CInt 45 | sizeofSocketAddressInternet = #{size struct sockaddr_in} 46 | 47 | internalWriteSocketAddressInternet :: 48 | MutableByteArray s -- ^ Buffer, must have length of @sockaddr_in@ 49 | -> SocketAddressInternet 50 | -> ST s () 51 | internalWriteSocketAddressInternet bs (SocketAddressInternet {port, address}) = do 52 | -- Initialize the bytearray by filling it with zeroes to ensure 53 | -- that the sin_zero padding that linux expects is properly zeroed. 54 | PM.setByteArray bs 0 #{size struct sockaddr_in} (0 :: Word8) 55 | -- ATM: I cannot find a way to poke AF_INET into the socket address 56 | -- without hardcoding the expected length (CUShort). There may be 57 | -- a way to use hsc2hs to convert a size to a haskell type, but 58 | -- I am not sure of how to do this. At any rate, I do not expect 59 | -- that linux will ever change the bit size of sa_family_t, so I 60 | -- am not too concerned. 61 | #{writeByteArray struct sockaddr_in, sin_family} bs 0 (#{const AF_INET} :: CUShort) 62 | -- The port and the address are already supposed to be in network 63 | -- byte order in the SocketAddressInternet data type. 64 | #{writeByteArray struct sockaddr_in, sin_port} bs 0 port 65 | #{writeByteArray struct sockaddr_in, sin_addr.s_addr} bs 0 address 66 | 67 | -- | Serialize a IPv4 socket address so that it may be passed to @bind@. 68 | -- This serialization is operating-system dependent. 69 | encodeSocketAddressInternet :: SocketAddressInternet -> SocketAddress 70 | encodeSocketAddressInternet sockAddrInternet = 71 | SocketAddress $ runByteArrayST $ unboxByteArrayST $ do 72 | bs <- PM.newByteArray #{size struct sockaddr_in} 73 | internalWriteSocketAddressInternet bs sockAddrInternet 74 | r <- PM.unsafeFreezeByteArray bs 75 | pure r 76 | 77 | -- | Decode a @sockaddr_in@ from a @sockaddr@ of an unknown 78 | -- family. This returns nothing when the size of the @sockaddr@ 79 | -- is wrong or when the @sin_family@ is not @AF_INET@. 80 | decodeSocketAddressInternet :: SocketAddress -> Maybe SocketAddressInternet 81 | decodeSocketAddressInternet (SocketAddress arr) = 82 | if PM.sizeofByteArray arr == (#{size struct sockaddr_in}) 83 | -- We assume that AF_INET takes up 16 bits. See the comment in 84 | -- encodeSocketAddressInternet for more detail. 85 | then if (#{indexByteArray struct sockaddr_in, sin_family} arr 0) == (#{const AF_INET} :: CUShort) 86 | then Just $ SocketAddressInternet 87 | { port = #{indexByteArray struct sockaddr_in, sin_port} arr 0 88 | , address = #{indexByteArray struct sockaddr_in, sin_addr.s_addr} arr 0 89 | } 90 | else Nothing 91 | else Nothing 92 | 93 | -- | This is unsafe, but it is needed for the wrappers of @recvmmsg@. 94 | -- The index uses @sockaddr_in@s as elements, not bytes. The caller of this 95 | -- function is responsible for bounds checks. Returns the actual (non-internet) 96 | -- socket family on a failure to parse. 97 | indexSocketAddressInternet :: Addr -> Int -> IO (Either CInt SocketAddressInternet) 98 | indexSocketAddressInternet addr ix = do 99 | fam <- #{peek struct sockaddr_in, sin_family} ptr 100 | if fam == (#{const AF_INET} :: CUShort) 101 | then do 102 | port <- #{peek struct sockaddr_in, sin_port} ptr 103 | address <- #{peek struct sockaddr_in, sin_addr.s_addr} ptr 104 | pure (Right (SocketAddressInternet { port, address })) 105 | else pure (Left (cushortToCInt fam)) 106 | where 107 | !(Addr offAddr) = PMA.plusAddr addr (ix * (#{size struct sockaddr_in})) 108 | ptr = Ptr offAddr 109 | 110 | -- | Serialize a unix domain socket address so that it may be passed to @bind@. 111 | -- This serialization is operating-system dependent. If the path provided by 112 | -- the argument equals or exceeds the size of @sun_path@ (typically in the range 92 113 | -- to 108 but varies by platform), the socket address will instead be given the 114 | -- empty string as its path. This typically results in @bind@ returning an 115 | -- error code. 116 | encodeSocketAddressUnix :: SocketAddressUnix -> SocketAddress 117 | encodeSocketAddressUnix (SocketAddressUnix !name) = 118 | SocketAddress $ runByteArrayST $ unboxByteArrayST $ do 119 | -- On linux, sun_path always has exactly 108 bytes. It is a null-terminated 120 | -- string, so we initialize the byte array to zeroes to ensure this 121 | -- happens. 122 | let pathSize = 108 :: Int 123 | -- Again, we hard-code the size of sa_family_t as the size of 124 | -- an unsigned short. 125 | let familySize = FS.sizeOf (undefined :: CUShort) 126 | bs <- PM.newByteArray (pathSize + familySize) 127 | PM.setByteArray bs familySize pathSize (0 :: Word8) 128 | PM.writeByteArray bs 0 (#{const AF_UNIX} :: CUShort) 129 | let sz = PM.sizeofByteArray name 130 | when (sz < pathSize) $ do 131 | PM.copyByteArray bs familySize name 0 sz 132 | PM.unsafeFreezeByteArray bs 133 | 134 | cushortToCInt :: CUShort -> CInt 135 | cushortToCInt = fromIntegral 136 | 137 | unboxByteArrayST :: ST s ByteArray -> State## s -> (## State## s, ByteArray## ##) 138 | unboxByteArrayST (ST f) s = case f s of 139 | (## s', ByteArray b ##) -> (## s', b ##) 140 | 141 | -- This is a specialization of runST that avoids a needless 142 | -- data constructor allocation. 143 | runByteArrayST :: (State## RealWorld -> (## State## RealWorld, ByteArray## ##)) -> ByteArray 144 | runByteArrayST st_rep = case runRW## st_rep of (## _, a ##) -> ByteArray a 145 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE BinaryLiterals #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE NamedFieldPuns #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | 8 | import Control.Concurrent (forkIO, threadWaitWrite) 9 | import Control.Monad (when) 10 | import Data.Primitive (ByteArray, MutableByteArray (..), MutablePrimArray (..)) 11 | import Data.Word (Word8) 12 | import Foreign.C.Error (Errno, errnoToIOError) 13 | import Foreign.C.Types (CSize) 14 | import GHC.Exts (RealWorld) 15 | import Numeric (showIntAtBase) 16 | import Test.Tasty 17 | import Test.Tasty.HUnit 18 | 19 | import qualified Data.Primitive as PM 20 | import qualified Data.Primitive.MVar as PM 21 | import qualified GHC.Exts as E 22 | import qualified Linux.Epoll as Epoll 23 | import qualified Posix.Socket as S 24 | 25 | main :: IO () 26 | main = defaultMain tests 27 | 28 | tests :: TestTree 29 | tests = 30 | testGroup 31 | "tests" 32 | [ testGroup 33 | "posix" 34 | [ testGroup 35 | "sockets" 36 | [ testCase "A" testSocketsA 37 | , testCase "B" testSocketsB 38 | , testCase "C" testSocketsC 39 | , testCase "D" testSocketsD 40 | ] 41 | ] 42 | , testGroup 43 | "linux" 44 | [ testGroup 45 | "epoll" 46 | [ testCase "A" testLinuxEpollA 47 | ] 48 | ] 49 | ] 50 | 51 | testSocketsA :: Assertion 52 | testSocketsA = do 53 | (a, b) <- demand =<< S.uninterruptibleSocketPair S.Unix S.datagram S.defaultProtocol 54 | m <- PM.newEmptyMVar 55 | _ <- forkIO $ S.receiveByteArray b 5 mempty >>= PM.putMVar m 56 | bytesSent <- demand =<< S.sendByteArray a sample 0 5 mempty 57 | when (bytesSent /= 5) (fail "testSocketsA: bytesSent was wrong") 58 | actual <- demand =<< PM.takeMVar m 59 | sample @=? actual 60 | 61 | testSocketsB :: Assertion 62 | testSocketsB = do 63 | let limit = 10 64 | wordSz = PM.sizeOf (undefined :: Int) 65 | cwordSz = fromIntegral wordSz :: CSize 66 | (a, b) <- demand =<< S.uninterruptibleSocketPair S.Unix S.datagram S.defaultProtocol 67 | lock <- PM.newEmptyMVar 68 | let go1 !(ix :: Int) !(n :: Int) = 69 | if (ix < limit) 70 | then do 71 | y <- PM.newByteArray wordSz 72 | PM.writeByteArray y 0 (1 + n) 73 | z <- PM.unsafeFreezeByteArray y 74 | oneWord =<< demand =<< S.sendByteArray b z 0 cwordSz mempty 75 | x <- demand =<< S.receiveByteArray b cwordSz mempty 76 | go1 (ix + 1) (PM.indexByteArray x 0) 77 | else pure n 78 | go2 !(ix :: Int) = 79 | if (ix < limit) 80 | then do 81 | x <- demand =<< S.receiveByteArray a cwordSz mempty 82 | y <- PM.newByteArray wordSz 83 | PM.writeByteArray y 0 (1 + PM.indexByteArray x 0 :: Int) 84 | z <- PM.unsafeFreezeByteArray y 85 | oneWord =<< demand =<< S.sendByteArray a z 0 cwordSz mempty 86 | go2 (ix + 1) 87 | else PM.putMVar lock () 88 | _ <- forkIO (go2 0) 89 | r <- go1 0 0 90 | PM.takeMVar lock 91 | 20 @=? r 92 | 93 | testSocketsC :: Assertion 94 | testSocketsC = do 95 | (a, b) <- demand =<< S.uninterruptibleSocketPair S.Unix S.datagram S.defaultProtocol 96 | m <- PM.newEmptyMVar 97 | _ <- forkIO $ S.receiveByteArray a 5 mempty >>= PM.putMVar m 98 | bytesSent <- demand =<< S.sendByteArray b sample 0 5 mempty 99 | when (bytesSent /= 5) (fail "testSocketsC: bytesSent was wrong") 100 | actual <- demand =<< PM.takeMVar m 101 | sample @=? actual 102 | 103 | testSocketsD :: Assertion 104 | testSocketsD = do 105 | (a, b) <- demand =<< S.uninterruptibleSocketPair S.Unix S.datagram S.defaultProtocol 106 | _ <- forkIO $ do 107 | bytesSent <- demand =<< S.sendByteArray b sample 0 5 mempty 108 | when (bytesSent /= 5) (fail "testSocketsD: bytesSent was wrong") 109 | actual <- demand =<< S.receiveByteArray a 5 mempty 110 | sample @=? actual 111 | 112 | -- This test opens two datagram sockets and send a message from each 113 | -- one to the other. Then it checks that epoll's event-triggered 114 | -- interface correctly notifies the user about the read-readiness 115 | -- that has happened. 116 | testLinuxEpollA :: Assertion 117 | testLinuxEpollA = do 118 | (a, b) <- demand =<< S.uninterruptibleSocketPair S.Unix S.datagram S.defaultProtocol 119 | epfd <- demand =<< Epoll.uninterruptibleCreate 1 120 | reg <- PM.newPrimArray 1 121 | PM.writePrimArray reg 0 $ 122 | Epoll.Event 123 | { Epoll.events = Epoll.input <> Epoll.edgeTriggered 124 | , Epoll.payload = a 125 | } 126 | demand =<< Epoll.uninterruptibleControlMutablePrimArray epfd Epoll.add a reg 127 | PM.writePrimArray reg 0 $ 128 | Epoll.Event 129 | { Epoll.events = Epoll.input <> Epoll.edgeTriggered 130 | , Epoll.payload = b 131 | } 132 | demand =<< Epoll.uninterruptibleControlMutablePrimArray epfd Epoll.add b reg 133 | threadWaitWrite b 134 | bytesSentB <- demand =<< S.uninterruptibleSendByteArray b sample 0 5 mempty 135 | when (bytesSentB /= 5) (fail "testLinuxEpollA: bytesSentB was wrong") 136 | threadWaitWrite a 137 | bytesSentA <- demand =<< S.uninterruptibleSendByteArray a sample 0 5 mempty 138 | when (bytesSentA /= 5) (fail "testLinuxEpollA: bytesSentA was wrong") 139 | evs <- PM.newPrimArray 3 140 | loadGarbage evs 141 | evCount <- demand =<< Epoll.waitMutablePrimArray epfd evs 3 (-1) 142 | when (evCount /= 2) (fail ("testLinuxEpollA: evCount was " ++ show evCount)) 143 | r <- case () of 144 | _ -> do 145 | Epoll.Event {Epoll.events, Epoll.payload} <- PM.readPrimArray evs 0 146 | when (payload /= a && payload /= b) (fail ("testLinuxEpollA: payload x was " ++ show payload)) 147 | let Epoll.Events e = events 148 | when (not (Epoll.containsAnyEvents events Epoll.input)) $ do 149 | fail ("testLinuxEpollA: events x bitmask " ++ showIntAtBase 2 binChar e " missing EPOLLIN") 150 | pure payload 151 | Epoll.Event {Epoll.events, Epoll.payload} <- PM.readPrimArray evs 1 152 | when (payload == r) (fail ("testLinuxEpollA: same payload " ++ show payload ++ " for both events")) 153 | when (payload /= a && payload /= b) (fail ("testLinuxEpollA: payload y was " ++ show payload)) 154 | let Epoll.Events e = events 155 | when (not (Epoll.containsAnyEvents events Epoll.input)) $ do 156 | fail ("testLinuxEpollA: events y bitmask " ++ showIntAtBase 2 binChar e " missing EPOLLIN") 157 | pure () 158 | 159 | binChar :: Int -> Char 160 | binChar = \case 161 | 0 -> '0' 162 | 1 -> '1' 163 | _ -> 'x' 164 | 165 | loadGarbage :: MutablePrimArray RealWorld a -> IO () 166 | loadGarbage (MutablePrimArray x) = do 167 | let arr = MutableByteArray x 168 | go :: Int -> IO () 169 | go !ix = 170 | if ix > (-1) 171 | then do 172 | PM.writeByteArray arr ix ((0b01010101 :: Word8) + fromIntegral ix) 173 | go (ix - 1) 174 | else pure () 175 | n <- PM.getSizeofMutableByteArray arr 176 | go (n - 1) 177 | 178 | sample :: ByteArray 179 | sample = E.fromList [1, 2, 3, 4, 5] 180 | 181 | demand :: Either Errno a -> IO a 182 | demand = either (\e -> ioError (errnoToIOError "test" e Nothing Nothing)) pure 183 | 184 | oneWord :: CSize -> IO () 185 | oneWord x = if x == fromIntegral (PM.sizeOf (undefined :: Int)) then pure () else fail "expected one machine word" 186 | -------------------------------------------------------------------------------- /src/Linux/Socket/Types.hsc: -------------------------------------------------------------------------------- 1 | {-# language DataKinds #-} 2 | {-# language DerivingStrategies #-} 3 | {-# language DuplicateRecordFields #-} 4 | {-# language GeneralizedNewtypeDeriving #-} 5 | {-# language BinaryLiterals #-} 6 | {-# language TypeApplications #-} 7 | 8 | -- This is needed because hsc2hs does not currently handle ticked 9 | -- promoted data constructors correctly. 10 | {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} 11 | 12 | #define _GNU_SOURCE 13 | #include 14 | #include 15 | #include 16 | #include 17 | #include 18 | #include "custom.h" 19 | 20 | -- | All of the data constructors provided by this module are unsafe. 21 | -- Only use them if you really know what you are doing. 22 | module Linux.Socket.Types 23 | ( SocketFlags(..) 24 | , dontWait 25 | , truncate 26 | , controlTruncate 27 | , closeOnExec 28 | , nonblocking 29 | , headerInclude 30 | -- * Multiple Message Header 31 | , pokeMultipleMessageHeaderName 32 | , pokeMultipleMessageHeaderNameLength 33 | , pokeMultipleMessageHeaderIOVector 34 | , pokeMultipleMessageHeaderIOVectorLength 35 | , pokeMultipleMessageHeaderControl 36 | , pokeMultipleMessageHeaderControlLength 37 | , pokeMultipleMessageHeaderFlags 38 | , pokeMultipleMessageHeaderLength 39 | , peekMultipleMessageHeaderLength 40 | , peekMultipleMessageHeaderNameLength 41 | , sizeofMultipleMessageHeader 42 | -- * UDP Header 43 | , sizeofUdpHeader 44 | , pokeUdpHeaderSourcePort 45 | , pokeUdpHeaderDestinationPort 46 | , pokeUdpHeaderLength 47 | , pokeUdpHeaderChecksum 48 | -- * IPv4 Header 49 | , sizeofIpHeader 50 | , pokeIpHeaderVersionIhl 51 | , pokeIpHeaderTypeOfService 52 | , pokeIpHeaderTotalLength 53 | , pokeIpHeaderIdentifier 54 | , pokeIpHeaderFragmentOffset 55 | , pokeIpHeaderTimeToLive 56 | , pokeIpHeaderProtocol 57 | , pokeIpHeaderChecksum 58 | , pokeIpHeaderSourceAddress 59 | , pokeIpHeaderDestinationAddress 60 | ) where 61 | 62 | import Prelude hiding (truncate) 63 | 64 | import Data.Bits (Bits((.|.))) 65 | import Data.Word (Word8,Word16,Word32) 66 | import Data.Primitive.Addr (Addr(..),writeOffAddr) 67 | import Foreign.C.Types (CInt(..),CSize,CUInt) 68 | import Posix.Socket (MessageFlags(..),Message(Receive),OptionName(..)) 69 | import Foreign.Storable (peekByteOff,pokeByteOff) 70 | import GHC.Ptr (Ptr(..)) 71 | 72 | newtype SocketFlags = SocketFlags CInt 73 | deriving stock (Eq) 74 | deriving newtype (Bits) 75 | 76 | -- newtype Collection :: Type -> Type where 77 | -- Collection :: !(Ptr a) -> Collection a 78 | -- 79 | -- indexCollection :: Ptr a 80 | -- => Collection a -> Int -> IO (Ptr a) 81 | -- indexCollection (Collection p) n = advancePtr p n 82 | -- data MessageHeader = MessageHeader 83 | -- { name :: !Addr 84 | -- , nameLength :: !CInt 85 | -- , vector :: !(Ptr InputOutputVector) 86 | -- , vectorLength :: !CSize 87 | -- , control :: !(Ptr ControlMessageHeader) 88 | -- , controlLength :: !CSize 89 | -- , flags :: !(MessageFlags Receive) 90 | -- } 91 | -- 92 | -- data IOVector = IOVector 93 | -- { base :: !Addr 94 | -- , length :: !CSize 95 | -- } 96 | -- 97 | -- data ControlMessageHeader = ControlMessageHeader 98 | -- { length :: !CInt 99 | -- , level :: !CInt 100 | -- , type_ :: !CInt 101 | -- , data_ :: !Addr 102 | -- } 103 | 104 | instance Semigroup SocketFlags where (<>) = (.|.) 105 | instance Monoid SocketFlags where mempty = SocketFlags 0 106 | 107 | -- | The @MSG_DONTWAIT@ receive flag or send flag. 108 | dontWait :: MessageFlags m 109 | dontWait = MessageFlags #{const MSG_DONTWAIT} 110 | 111 | -- | The @MSG_TRUNC@ receive flag. 112 | truncate :: MessageFlags Receive 113 | truncate = MessageFlags #{const MSG_TRUNC} 114 | 115 | -- | The @MSG_CTRUNC@ receive flag. 116 | controlTruncate :: MessageFlags Receive 117 | controlTruncate = MessageFlags #{const MSG_CTRUNC} 118 | 119 | -- | The @SOCK_CLOEXEC@ receive flag or send flag. 120 | closeOnExec :: SocketFlags 121 | closeOnExec = SocketFlags #{const SOCK_CLOEXEC} 122 | 123 | -- | The @SOCK_NONBLOCK@ receive flag or send flag. 124 | nonblocking :: SocketFlags 125 | nonblocking = SocketFlags #{const SOCK_NONBLOCK} 126 | 127 | -- | If enabled, the user supplies an IP header in front of the 128 | -- user data. Valid only for @SOCK_RAW@ sockets. 129 | headerInclude :: OptionName 130 | headerInclude = OptionName #{const IP_HDRINCL} 131 | 132 | -- | The size of a @mmsghdr@ struct. 133 | sizeofMultipleMessageHeader :: CInt 134 | sizeofMultipleMessageHeader = #{size struct mmsghdr} 135 | 136 | pokeMultipleMessageHeaderName :: Addr -> Addr -> IO () 137 | pokeMultipleMessageHeaderName (Addr p) (Addr x) = #{poke struct mmsghdr, msg_hdr.msg_name} (Ptr p) (Ptr x) 138 | 139 | pokeMultipleMessageHeaderNameLength :: Addr -> CInt -> IO () 140 | pokeMultipleMessageHeaderNameLength (Addr p) = #{poke struct mmsghdr, msg_hdr.msg_namelen} (Ptr p) 141 | 142 | pokeMultipleMessageHeaderIOVector :: Addr -> Addr -> IO () 143 | pokeMultipleMessageHeaderIOVector (Addr p) (Addr x) = #{poke struct mmsghdr, msg_hdr.msg_iov} (Ptr p) (Ptr x) 144 | 145 | pokeMultipleMessageHeaderIOVectorLength :: Addr -> CSize -> IO () 146 | pokeMultipleMessageHeaderIOVectorLength (Addr p) = #{poke struct mmsghdr, msg_hdr.msg_iovlen} (Ptr p) 147 | 148 | pokeMultipleMessageHeaderControl :: Addr -> Addr -> IO () 149 | pokeMultipleMessageHeaderControl (Addr p) (Addr x) = #{poke struct mmsghdr, msg_hdr.msg_control} (Ptr p) (Ptr x) 150 | 151 | pokeMultipleMessageHeaderControlLength :: Addr -> CSize -> IO () 152 | pokeMultipleMessageHeaderControlLength (Addr p) = #{poke struct mmsghdr, msg_hdr.msg_controllen} (Ptr p) 153 | 154 | pokeMultipleMessageHeaderFlags :: Addr -> MessageFlags Receive -> IO () 155 | pokeMultipleMessageHeaderFlags (Addr p) (MessageFlags i) = #{poke struct mmsghdr, msg_hdr.msg_flags} (Ptr p) i 156 | 157 | pokeMultipleMessageHeaderLength :: Addr -> CUInt -> IO () 158 | pokeMultipleMessageHeaderLength (Addr p) i = #{poke struct mmsghdr, msg_len} (Ptr p) i 159 | 160 | peekMultipleMessageHeaderNameLength :: Addr -> IO CInt 161 | peekMultipleMessageHeaderNameLength (Addr p) = #{peek struct mmsghdr, msg_hdr.msg_namelen} (Ptr p) 162 | 163 | peekMultipleMessageHeaderLength :: Addr -> IO CUInt 164 | peekMultipleMessageHeaderLength (Addr p) = #{peek struct mmsghdr, msg_len} (Ptr p) 165 | 166 | -- | The size of a @udphdr@ struct. 167 | sizeofUdpHeader :: CInt 168 | sizeofUdpHeader = #{size struct udphdr} 169 | 170 | pokeUdpHeaderSourcePort :: Addr -> Word16 -> IO () 171 | pokeUdpHeaderSourcePort (Addr p) = #{poke struct udphdr, source} (Ptr p) 172 | 173 | pokeUdpHeaderDestinationPort :: Addr -> Word16 -> IO () 174 | pokeUdpHeaderDestinationPort (Addr p) = #{poke struct udphdr, dest} (Ptr p) 175 | 176 | pokeUdpHeaderLength :: Addr -> Word16 -> IO () 177 | pokeUdpHeaderLength (Addr p) = #{poke struct udphdr, len} (Ptr p) 178 | 179 | pokeUdpHeaderChecksum :: Addr -> Word16 -> IO () 180 | pokeUdpHeaderChecksum (Addr p) = #{poke struct udphdr, check} (Ptr p) 181 | 182 | -- | The size of an @iphdr@ struct. 183 | sizeofIpHeader :: CInt 184 | sizeofIpHeader = #{size struct iphdr} 185 | 186 | -- | This poke function requires the user to pack the version and the 187 | -- internet header length (IHL), each 4 bits, into a single 8-bit word. 188 | -- The version should be in the most significant bits. This function 189 | -- will marshal the value appropriately depending on the platform's 190 | -- bit-endianness. 191 | pokeIpHeaderVersionIhl :: Addr -> Word8 -> IO () 192 | -- TODO: Verify if this is correct. Also, something bad is going 193 | -- on here. Fix this. 194 | #if defined(__LITTLE_ENDIAN_BITFIELD) 195 | pokeIpHeaderVersionIhl p _ = writeOffAddr p 0 (0b01000101 :: Word8) 196 | #elif defined (__BIG_ENDIAN_BITFIELD) 197 | pokeIpHeaderVersionIhl p w = PM.writeOffAddr p 0 w 198 | #else 199 | ERROR_BITFIELD_ENDIANNESS_NOT_SET 200 | #endif 201 | 202 | pokeIpHeaderTypeOfService :: Addr -> Word8 -> IO () 203 | pokeIpHeaderTypeOfService (Addr p) = #{poke struct iphdr, tos} (Ptr p) 204 | 205 | pokeIpHeaderTotalLength :: Addr -> Word16 -> IO () 206 | pokeIpHeaderTotalLength (Addr p) = #{poke struct iphdr, tot_len} (Ptr p) 207 | 208 | pokeIpHeaderIdentifier :: Addr -> Word16 -> IO () 209 | pokeIpHeaderIdentifier (Addr p) = #{poke struct iphdr, id} (Ptr p) 210 | 211 | pokeIpHeaderFragmentOffset :: Addr -> Word16 -> IO () 212 | pokeIpHeaderFragmentOffset (Addr p) = #{poke struct iphdr, frag_off} (Ptr p) 213 | 214 | pokeIpHeaderTimeToLive :: Addr -> Word8 -> IO () 215 | pokeIpHeaderTimeToLive (Addr p) = #{poke struct iphdr, ttl} (Ptr p) 216 | 217 | pokeIpHeaderProtocol :: Addr -> Word8 -> IO () 218 | pokeIpHeaderProtocol (Addr p) = #{poke struct iphdr, protocol} (Ptr p) 219 | 220 | pokeIpHeaderChecksum :: Addr -> Word16 -> IO () 221 | pokeIpHeaderChecksum (Addr p) = #{poke struct iphdr, check} (Ptr p) 222 | 223 | pokeIpHeaderSourceAddress :: Addr -> Word32 -> IO () 224 | pokeIpHeaderSourceAddress (Addr p) = #{poke struct iphdr, saddr} (Ptr p) 225 | 226 | pokeIpHeaderDestinationAddress :: Addr -> Word32 -> IO () 227 | pokeIpHeaderDestinationAddress (Addr p) = #{poke struct iphdr, daddr} (Ptr p) 228 | -------------------------------------------------------------------------------- /cbits/HaskellPosix.c: -------------------------------------------------------------------------------- 1 | #define _GNU_SOURCE 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include "HaskellPosix.h" 11 | #include "Rts.h" 12 | 13 | #ifdef __GNUC__ 14 | #define likely(x) __builtin_expect(!!(x), 1) 15 | #define unlikely(x) __builtin_expect(!!(x), 0) 16 | #else 17 | #define likely(x) (x) 18 | #define unlikely(x) (x) 19 | #endif 20 | 21 | #define MAX_BYTEARRAYS 64 22 | 23 | // Generally, this library tries to avoid wrapping POSIX functions 24 | // in an additional function. However, for some functions whose 25 | // unsafe FFI wrappers use unpinned ByteArray instead of Addr, the only 26 | // way to support providing an offset (without just copying the bytes 27 | // into pinned memory) is to use a wrapper. 28 | 29 | // This returns an error code, not a length of written bytes. The error 30 | // code zero means "no error". 31 | int write_offset_loop(int fd, const char *message, HsInt offset, size_t length){ 32 | ssize_t r; 33 | size_t bytesSent; 34 | const char* buf = message + offset; 35 | while(length > 0){ 36 | if ((r = write(fd, (const void*)buf, length)) == -1) { 37 | return errno; 38 | } else { 39 | bytesSent = (size_t)r; 40 | buf = buf + bytesSent; 41 | length = length - bytesSent; 42 | } 43 | } 44 | return 0; 45 | } 46 | ssize_t write_offset(int fd, const char *message, HsInt offset, size_t length){ 47 | return write(fd, (const void*)(message + offset), length); 48 | } 49 | ssize_t recv_offset(int socket, char *buffer, HsInt offset, size_t length, int flags) { 50 | return recv(socket, (void*)(buffer + offset), length, flags); 51 | } 52 | ssize_t read_offset(int fd, char *buffer, HsInt offset, size_t length) { 53 | return read(fd, (void*)(buffer + offset), length); 54 | } 55 | ssize_t send_offset(int socket, const char *buffer, HsInt offset, size_t length, int flags) { 56 | return send(socket, (const void*)(buffer + offset), length, flags); 57 | } 58 | ssize_t sendto_offset(int socket, const char *message, HsInt offset, size_t length, int flags, const struct sockaddr *dest_addr, socklen_t dest_len){ 59 | return sendto(socket, (const void*)(message + offset), length, flags, dest_addr, dest_len); 60 | } 61 | ssize_t sendto_inet_offset(int socket, const char *message, HsInt offset, size_t length, int flags, uint16_t port, uint32_t inet_addr){ 62 | struct sockaddr_in dest; 63 | memset(&dest, 0, sizeof(dest)); 64 | dest.sin_family = AF_INET; 65 | dest.sin_addr.s_addr = inet_addr; 66 | dest.sin_port = port; 67 | return sendto(socket, (const void*)(message + offset), length, flags, (struct sockaddr*)&dest, sizeof(dest)); 68 | } 69 | ssize_t sendto_inet_addr(int socket, const void *message, size_t length, int flags, uint16_t port, uint32_t inet_addr){ 70 | struct sockaddr_in dest; 71 | memset(&dest, 0, sizeof(dest)); 72 | dest.sin_family = AF_INET; 73 | dest.sin_addr.s_addr = inet_addr; 74 | dest.sin_port = port; 75 | return sendto(socket, message, length, flags, (struct sockaddr*)&dest, sizeof(dest)); 76 | } 77 | ssize_t recvfrom_offset(int socket, char *restrict buffer, HsInt offset, size_t length, int flags, struct sockaddr *restrict address, socklen_t *restrict address_len) { 78 | return recvfrom(socket, (void*)(buffer + offset), length, flags, address, address_len); 79 | } 80 | ssize_t recvfrom_offset_peerless(int socket, char *restrict buffer, HsInt offset, size_t length, int flags) { 81 | return recvfrom(socket, (void*)(buffer + offset), length, flags, NULL, NULL); 82 | } 83 | ssize_t recvfrom_addr_peerless(int socket, void *restrict buffer, size_t length, int flags) { 84 | return recvfrom(socket, buffer, length, flags, NULL, NULL); 85 | } 86 | ssize_t recvfrom_offset_inet 87 | ( int socket 88 | , char *restrict buffer_base 89 | , HsInt offset 90 | , size_t length 91 | , int flags 92 | , struct sockaddr_in *restrict addresses 93 | , HsInt address_offset 94 | ) { 95 | void* buffer = (void*)(buffer_base + offset); 96 | struct sockaddr_in* address = addresses + address_offset; 97 | socklen_t address_len[1] = {sizeof(struct sockaddr_in)}; 98 | ssize_t r = recvfrom(socket, buffer, length, flags, address, address_len); 99 | if (likely(address_len[0] == sizeof(struct sockaddr_in))) { 100 | return r; 101 | } else { 102 | fprintf(stderr, "posix-api: recvfrom_offset_bufs"); 103 | exit(EXIT_FAILURE); 104 | } 105 | } 106 | ssize_t recvfrom_offset_inet_addr 107 | ( int socket 108 | , void *restrict buffer 109 | , size_t length 110 | , int flags 111 | , struct sockaddr_in *restrict addresses 112 | , HsInt address_offset 113 | ) { 114 | struct sockaddr_in* address = addresses + address_offset; 115 | socklen_t address_len[1] = {sizeof(struct sockaddr_in)}; 116 | ssize_t r = recvfrom(socket, buffer, length, flags, address, address_len); 117 | if (likely(address_len[0] == sizeof(struct sockaddr_in))) { 118 | return r; 119 | } else { 120 | fprintf(stderr, "posix-api: recvfrom_offset_bufs"); 121 | exit(EXIT_FAILURE); 122 | } 123 | } 124 | int setsockopt_int(int socket, int level, int option_name, int option_value) { 125 | return setsockopt(socket,level,option_name,&option_value,sizeof(int)); 126 | } 127 | 128 | ssize_t sendmsg_bytearrays 129 | ( int sockfd 130 | , StgArrBytes **arrs // used for input 131 | , HsInt off // offset into input chunk array 132 | , HsInt len0 // number of chunks to send 133 | , HsInt offC // offset into first chunk 134 | , int flags 135 | ) { 136 | struct iovec bufs[MAX_BYTEARRAYS]; 137 | HsInt len1 = len0 > MAX_BYTEARRAYS ? MAX_BYTEARRAYS : len0; 138 | // We must handle the first chunk specially since 139 | // the user can provide an offset into it. 140 | if(len1 > 0) { 141 | bufs[0].iov_base = 142 | (void*)(((char*)(arrs[off]->payload)) + offC); 143 | bufs[0].iov_len = 144 | (size_t)(((HsInt)(arrs[off]->bytes)) - offC); 145 | } 146 | for (HsInt i = 1; i < len1; i++) { 147 | bufs[i].iov_base = (void*)(arrs[off + i]->payload); 148 | bufs[i].iov_len = (size_t)(arrs[off + i]->bytes); 149 | } 150 | // The msg_flags field is not used when sending. 151 | // Consequently, we do not write to it or read from it. 152 | struct msghdr msg = 153 | { .msg_name = NULL 154 | , .msg_namelen = 0 155 | , .msg_iov = bufs 156 | , .msg_iovlen = (size_t)len1 157 | , .msg_control = NULL 158 | , .msg_controllen = 0 159 | }; 160 | return sendmsg(sockfd,&msg,flags); 161 | } 162 | 163 | // The second buffer is char* instead of void* because we need 164 | // to apply an offset to it. 165 | ssize_t sendmsg_a 166 | ( int sockfd 167 | , void *bufA 168 | , size_t lenA 169 | , char *bufB 170 | , HsInt offB 171 | , size_t lenB 172 | , int flags 173 | ) { 174 | struct iovec bufs[2] = 175 | { { .iov_base = bufA, .iov_len = lenA } 176 | , { .iov_base = (void*)(bufB + offB), .iov_len = lenB } 177 | }; 178 | struct msghdr msg = 179 | { .msg_name = NULL 180 | , .msg_namelen = 0 181 | , .msg_iov = bufs 182 | , .msg_iovlen = 2 183 | , .msg_control = NULL 184 | , .msg_controllen = 0 185 | }; 186 | return sendmsg(sockfd,&msg,flags); 187 | } 188 | 189 | // The first buffer is char* instead of void* because we need 190 | // to apply an offset to it. 191 | ssize_t sendmsg_b 192 | ( int sockfd 193 | , char *bufA 194 | , HsInt offA 195 | , size_t lenA 196 | , void *bufB 197 | , size_t lenB 198 | , int flags 199 | ) { 200 | struct iovec bufs[2] = 201 | { { .iov_base = (void*)(bufA + offA), .iov_len = lenA } 202 | , { .iov_base = bufB, .iov_len = lenB } 203 | }; 204 | struct msghdr msg = 205 | { .msg_name = NULL 206 | , .msg_namelen = 0 207 | , .msg_iov = bufs 208 | , .msg_iovlen = 2 209 | , .msg_control = NULL 210 | , .msg_controllen = 0 211 | }; 212 | return sendmsg(sockfd,&msg,flags); 213 | } 214 | 215 | int recvmmsg_sockaddr_in 216 | ( int sockfd 217 | , int *lens // used for output 218 | , struct sockaddr_in *addrs // used for output 219 | , StgArrBytes **bufs // used for output 220 | , unsigned int vlen 221 | , int flags 222 | ) { 223 | // TODO: It's probably better to statically pick 224 | // out a maximum size for these. On the C stack, 225 | // the cost of doing this is basically nothing. 226 | // Perhaps 4096 would be a good maximum. 227 | struct mmsghdr msgs[vlen]; 228 | struct iovec vecs[vlen]; 229 | for(unsigned int i = 0; i < vlen; i++) { 230 | vecs[i].iov_base = (void*)(bufs[i]->payload); 231 | vecs[i].iov_len = (size_t)(bufs[i]->bytes); 232 | // We deliberately leave msg_len unassigned. 233 | msgs[i].msg_hdr.msg_name = addrs + i; 234 | msgs[i].msg_hdr.msg_namelen = sizeof(struct sockaddr_in); 235 | msgs[i].msg_hdr.msg_iov = vecs + i; 236 | msgs[i].msg_hdr.msg_iovlen = 1; 237 | msgs[i].msg_hdr.msg_control = NULL; 238 | msgs[i].msg_hdr.msg_controllen = 0; 239 | msgs[i].msg_hdr.msg_flags = flags; 240 | } 241 | int r = recvmmsg(sockfd,msgs,vlen,flags,NULL); 242 | // If no errors occurred, copy all of the lengths into the 243 | // length buffer. This copy makes me feel a little sad. 244 | // It is the only copy in a wrapper that otherwise is 245 | // able to share buffers perfectly between Haskell and C. 246 | if(r > (-1)) { 247 | for(int i = 0; i < r; i++) { 248 | lens[i] = msgs[i].msg_len; 249 | } 250 | } 251 | return r; 252 | } 253 | 254 | int recvmmsg_sockaddr_discard 255 | ( int sockfd 256 | , int *lens // used for output 257 | #if __GLASGOW_HASKELL__ >= 810 258 | , StgArrBytes **bufs // used for output 259 | #else 260 | , StgMutArrPtrs *arr // used for output 261 | #endif 262 | , unsigned int vlen 263 | , int flags 264 | ) { 265 | #if __GLASGOW_HASKELL__ < 810 266 | StgClosure **bufsX = arr->payload; 267 | StgArrBytes **bufs = (StgArrBytes**)bufsX; 268 | #endif 269 | struct mmsghdr msgs[vlen]; 270 | struct iovec vecs[vlen]; 271 | for(unsigned int i = 0; i < vlen; i++) { 272 | vecs[i].iov_base = (void*)(bufs[i]->payload); 273 | vecs[i].iov_len = (size_t)(bufs[i]->bytes); 274 | // We deliberately leave msg_len and msg_flags 275 | // unassigned since they are set by the syscall. 276 | msgs[i].msg_hdr.msg_name = NULL; 277 | msgs[i].msg_hdr.msg_namelen = 0; 278 | msgs[i].msg_hdr.msg_iov = vecs + i; 279 | msgs[i].msg_hdr.msg_iovlen = 1; 280 | msgs[i].msg_hdr.msg_control = NULL; 281 | msgs[i].msg_hdr.msg_controllen = 0; 282 | } 283 | int r = recvmmsg(sockfd,msgs,vlen,flags,NULL); 284 | // TODO: Check msg_flags for MSG_TRUNC. I currently 285 | // do this in haskell, but it is actually easier to 286 | // do here. 287 | 288 | // If no errors occurred, copy all of the lengths into the 289 | // length buffer. This copy makes me feel a little sad. 290 | // It is the only copy in a wrapper that otherwise is 291 | // able to share buffers perfectly between Haskell and C. 292 | if(r > (-1)) { 293 | for(int i = 0; i < r; i++) { 294 | lens[i] = msgs[i].msg_len; 295 | } 296 | } 297 | return r; 298 | } 299 | 300 | ssize_t mq_send_offset(mqd_t mqdes, const char *msg, HsInt offset, size_t len, unsigned int prio){ 301 | return mq_send(mqdes, msg + offset, len, prio); 302 | } 303 | 304 | int hs_get_fd_flags(int fd) { 305 | return fcntl(fd,F_GETFD); 306 | } 307 | 308 | int hs_get_fl_flags(int fd) { 309 | return fcntl(fd,F_GETFL); 310 | } 311 | -------------------------------------------------------------------------------- /src/Linux/Epoll/Types.hsc: -------------------------------------------------------------------------------- 1 | {-# language BangPatterns #-} 2 | {-# language BinaryLiterals #-} 3 | {-# language DataKinds #-} 4 | {-# language DerivingStrategies #-} 5 | {-# language DuplicateRecordFields #-} 6 | {-# language GADTSyntax #-} 7 | {-# language GeneralizedNewtypeDeriving #-} 8 | {-# language KindSignatures #-} 9 | {-# language MagicHash #-} 10 | {-# language NamedFieldPuns #-} 11 | {-# language PolyKinds #-} 12 | {-# language ScopedTypeVariables #-} 13 | {-# language TypeApplications #-} 14 | {-# language DataKinds #-} 15 | {-# language UnboxedTuples #-} 16 | 17 | -- This is needed because hsc2hs does not currently handle ticked 18 | -- promoted data constructors correctly. 19 | {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} 20 | 21 | #define _GNU_SOURCE 22 | #include 23 | #include "custom.h" 24 | 25 | -- | All of the data constructors provided by this module are unsafe. 26 | -- Only use them if you really know what you are doing. 27 | module Linux.Epoll.Types 28 | ( EpollFlags(..) 29 | , ControlOperation(..) 30 | , Exchange(..) 31 | , Events(..) 32 | , Event(..) 33 | , PrimEpollData(..) 34 | -- * Flags 35 | , closeOnExec 36 | , add 37 | , modify 38 | , delete 39 | -- * Events 40 | , input 41 | , output 42 | , priority 43 | , hangup 44 | , readHangup 45 | , error 46 | , edgeTriggered 47 | -- * Events Combinators 48 | , containsAnyEvents 49 | , containsAllEvents 50 | -- * Marshalling 51 | , sizeofEvent 52 | , peekEventEvents 53 | , peekEventDataFd 54 | , peekEventDataPtr 55 | , peekEventDataU32 56 | , peekEventDataU64 57 | , pokeEventDataU64 58 | -- , readEventDataU64 59 | -- , writeEventDataU64 60 | ) where 61 | 62 | import Prelude hiding (truncate,error) 63 | 64 | import Data.Bits (Bits,(.&.),(.|.),unsafeShiftL,unsafeShiftR) 65 | import Data.Kind (Type) 66 | import Data.Primitive.Addr (Addr(..)) 67 | import Data.Primitive (Prim) 68 | import Data.Primitive (indexByteArray##,writeByteArray##,readByteArray##) 69 | import Data.Primitive (indexOffAddr##,readOffAddr##,writeOffAddr##) 70 | import Data.Word (Word32,Word64) 71 | import Foreign.C.Types (CInt(..)) 72 | import Foreign.Storable (Storable,peekByteOff,pokeByteOff) 73 | import GHC.Exts (Int(I##),(+##),(*##)) 74 | import GHC.Exts (State##,Int##,Addr##,MutableByteArray##,ByteArray##) 75 | import GHC.Ptr (Ptr(..)) 76 | import Posix.Poll (Exchange(..)) 77 | import System.Posix.Types (Fd(..)) 78 | 79 | import qualified Data.Primitive as PM 80 | 81 | newtype ControlOperation = ControlOperation CInt 82 | deriving stock (Eq) 83 | 84 | newtype EpollFlags = EpollFlags CInt 85 | deriving stock (Eq) 86 | deriving newtype (Bits) 87 | 88 | instance Semigroup EpollFlags where (<>) = (.|.) 89 | instance Monoid EpollFlags where mempty = EpollFlags 0 90 | 91 | newtype Events :: Exchange -> Type where 92 | Events :: Word32 -> Events e 93 | deriving stock (Eq) 94 | deriving newtype (Bits,Storable,Prim) 95 | 96 | instance Semigroup (Events e) where (<>) = (.|.) 97 | instance Monoid (Events e) where mempty = Events 0 98 | 99 | -- | A data type corresponding to @struct epoll_event@. Linux 100 | -- defines this as: 101 | -- 102 | -- > typedef union epoll_data { 103 | -- > void *ptr; 104 | -- > int fd; 105 | -- > uint32_t u32; 106 | -- > uint64_t u64; 107 | -- > } epoll_data_t; 108 | -- > 109 | -- > struct epoll_event { 110 | -- > uint32_t events; /* Epoll events */ 111 | -- > epoll_data_t data; /* User data variable */ 112 | -- > }; 113 | -- 114 | -- It is a little difficult to capture what this type conveys, but 115 | -- we make an attempt. The second argument to the @Event@ type 116 | -- constructor is either @Addr@, @Fd@, @Word32@, or @Word64@. This 117 | -- corresponds to the four possibilities in the @epoll_data@ union 118 | -- type. As long as the user monomorphizes this type when using 119 | -- it, there should not be any performance penalty for the 120 | -- flexibility afforded by this approach. 121 | data Event :: Exchange -> Type -> Type where 122 | Event :: 123 | { events :: !(Events e) 124 | -- ^ Epoll events 125 | , payload :: !a 126 | -- ^ User data variable, named @data@ in @struct epoll_event@. 127 | } -> Event e a 128 | 129 | class PrimEpollData a where 130 | indexByteArrayEpoll :: ByteArray## -> Int## -> Event e a 131 | readByteArrayEpoll :: MutableByteArray## s -> Int## -> State## s -> (## State## s, Event e a ##) 132 | writeByteArrayEpoll :: MutableByteArray## s -> Int## -> Event e a -> State## s -> State## s 133 | indexOffAddrEpoll :: Addr## -> Int## -> Event e a 134 | readOffAddrEpoll :: Addr## -> Int## -> State## s -> (## State## s, Event e a ##) 135 | writeOffAddrEpoll :: Addr## -> Int## -> Event e a -> State## s -> State## s 136 | 137 | instance PrimEpollData a => Prim (Event e a) where 138 | {-# inline sizeOf# #-} 139 | {-# inline alignment# #-} 140 | {-# inline indexByteArray# #-} 141 | {-# inline readByteArray# #-} 142 | {-# inline writeByteArray# #-} 143 | {-# inline setByteArray# #-} 144 | {-# inline indexOffAddr# #-} 145 | {-# inline readOffAddr# #-} 146 | {-# inline writeOffAddr# #-} 147 | {-# inline setOffAddr# #-} 148 | sizeOf## _ = unI #{size struct epoll_event} 149 | alignment## _ = PM.alignment## (undefined :: Word32) 150 | indexByteArray## = indexByteArrayEpoll 151 | readByteArray## = readByteArrayEpoll 152 | writeByteArray## = writeByteArrayEpoll 153 | setByteArray## = PM.defaultSetByteArray## 154 | indexOffAddr## = indexOffAddrEpoll 155 | readOffAddr## = readOffAddrEpoll 156 | writeOffAddr## = writeOffAddrEpoll 157 | setOffAddr## = PM.defaultSetOffAddr## 158 | 159 | instance PrimEpollData Fd where 160 | {-# inline indexByteArrayEpoll #-} 161 | {-# inline readByteArrayEpoll #-} 162 | {-# inline writeByteArrayEpoll #-} 163 | {-# inline indexOffAddrEpoll #-} 164 | {-# inline readOffAddrEpoll #-} 165 | {-# inline writeOffAddrEpoll #-} 166 | indexByteArrayEpoll arr i = Event 167 | { events = #{indexByteArrayHash struct epoll_event, events} arr i 168 | , payload = #{indexByteArrayHash struct epoll_event, data.fd} arr i 169 | } 170 | writeByteArrayEpoll arr i Event{events,payload} s0 = 171 | case #{writeByteArrayHash struct epoll_event, events} arr i events s0 of 172 | s1 -> #{writeByteArrayHash struct epoll_event, data.fd} arr i payload s1 173 | readByteArrayEpoll arr i s0 = 174 | case #{readByteArrayHash struct epoll_event, events} arr i s0 of 175 | (## s1, events ##) -> case #{readByteArrayHash struct epoll_event, data.fd} arr i s1 of 176 | (## s2, payload ##) -> (## s2, Event{events,payload} ##) 177 | indexOffAddrEpoll arr i = Event 178 | { events = #{indexOffAddrHash struct epoll_event, events} arr i 179 | , payload = #{indexOffAddrHash struct epoll_event, data.fd} arr i 180 | } 181 | writeOffAddrEpoll arr i Event{events,payload} s0 = 182 | case #{writeOffAddrHash struct epoll_event, events} arr i events s0 of 183 | s1 -> #{writeOffAddrHash struct epoll_event, data.fd} arr i payload s1 184 | readOffAddrEpoll arr i s0 = 185 | case #{readOffAddrHash struct epoll_event, events} arr i s0 of 186 | (## s1, events ##) -> case #{readOffAddrHash struct epoll_event, data.fd} arr i s1 of 187 | (## s2, payload ##) -> (## s2, Event{events,payload} ##) 188 | 189 | -- | Since @epoll_event@ includes an unaligned 64-bit word, it is 190 | -- difficult to use @hsc2hs@ to generate the marshalling code. Consequently, 191 | -- the offsets of @events@ and @data@ are currently hardcoded. Open an 192 | -- issue in this causes a problem on your platform. 193 | instance PrimEpollData Word64 where 194 | {-# inline indexByteArrayEpoll #-} 195 | {-# inline readByteArrayEpoll #-} 196 | {-# inline writeByteArrayEpoll #-} 197 | {-# inline indexOffAddrEpoll #-} 198 | {-# inline readOffAddrEpoll #-} 199 | {-# inline writeOffAddrEpoll #-} 200 | indexByteArrayEpoll arr i = Event 201 | { events = PM.indexByteArray## arr (i *## 3##) 202 | , payload = composePayload 203 | (PM.indexByteArray## arr ((i *## 3##) +# 1##)) 204 | (PM.indexByteArray## arr ((i *## 3##) +# 2##)) 205 | } 206 | writeByteArrayEpoll arr i Event{events,payload} s0 = case PM.writeByteArray## arr (i *## 3##) events s0 of 207 | s1 -> case PM.writeByteArray## arr ((i *## 3##) +## 1##) pa s1 of 208 | s2 -> PM.writeByteArray## arr ((i *## 3##) +## 2##) pb s2 209 | where 210 | !(pa,pb) = decomposePayload payload 211 | readByteArrayEpoll arr i s0 = case PM.readByteArray## arr (i *## 3##) s0 of 212 | (## s1, events ##) -> case PM.readByteArray## arr ((i *## 3##) +## 1##) s1 of 213 | (## s2, pa ##) -> case PM.readByteArray## arr ((i *## 3##) +## 2##) s2 of 214 | (## s3, pb ##) -> let payload = composePayload pa pb in 215 | (## s3, Event{events,payload} ##) 216 | indexOffAddrEpoll arr i = Event 217 | { events = PM.indexOffAddr## arr (i *## 3##) 218 | , payload = composePayload 219 | (PM.indexOffAddr## arr ((i *## 3##) +## 1##)) 220 | (PM.indexOffAddr## arr ((i *## 3##) +## 2##)) 221 | } 222 | writeOffAddrEpoll arr i Event{events,payload} s0 = case PM.writeOffAddr## arr (i *## 3##) events s0 of 223 | s1 -> case PM.writeOffAddr## arr ((i *## 3##) +## 1##) pa s1 of 224 | s2 -> PM.writeOffAddr## arr ((i *## 3##) +## 2##) pb s2 225 | where 226 | !(pa,pb) = decomposePayload payload 227 | readOffAddrEpoll arr i s0 = case PM.readOffAddr## arr (i *## 3##) s0 of 228 | (## s1, events ##) -> case PM.readOffAddr## arr ((i *## 3##) +## 1##) s1 of 229 | (## s2, pa ##) -> case PM.readOffAddr## arr ((i *## 3##) +## 2##) s2 of 230 | (## s3, pb ##) -> let payload = composePayload pa pb in 231 | (## s3, Event{events,payload} ##) 232 | 233 | -- | The @EPOLL_CTL_ADD@ control operation. 234 | add :: ControlOperation 235 | add = ControlOperation #{const EPOLL_CTL_ADD} 236 | 237 | -- | The @EPOLL_CTL_MOD@ control operation. 238 | modify :: ControlOperation 239 | modify = ControlOperation #{const EPOLL_CTL_MOD} 240 | 241 | -- | The @EPOLL_CTL_DEL@ control operation. 242 | delete :: ControlOperation 243 | delete = ControlOperation #{const EPOLL_CTL_DEL} 244 | 245 | -- | The @EPOLL_CLOEXEC@ flag. 246 | closeOnExec :: EpollFlags 247 | closeOnExec = EpollFlags #{const EPOLL_CLOEXEC} 248 | 249 | -- | The @EPOLLIN@ event. Can appear in a request or a response. 250 | input :: Events e 251 | input = Events #{const EPOLLIN} 252 | 253 | -- | The @EPOLLOUT@ event. Can appear in a request or a response. 254 | output :: Events e 255 | output = Events #{const EPOLLOUT} 256 | 257 | -- | The @EPOLLPRI@ event. Can appear in a request or a response. 258 | priority :: Events e 259 | priority = Events #{const EPOLLPRI} 260 | 261 | -- | The @EPOLLERR@ event. The 262 | -- says 263 | -- "@epoll_wait@ will always wait for this event; it is not necessary to set it in @events@". 264 | -- Consequently, in this library, it has been marked as only appearing in @Response@ positions. 265 | error :: Events Response 266 | error = Events #{const EPOLLERR} 267 | 268 | -- | The @EPOLLHUP@ event. The 269 | -- says 270 | -- "@epoll_wait@ will always wait for this event; it is not necessary to set it in @events@". 271 | -- Consequently, in this library, it has been marked as only appearing in @Response@ positions. 272 | hangup :: Events Response 273 | hangup = Events #{const EPOLLHUP} 274 | 275 | -- | The @EPOLLRDHUP@ event. Can appear in a request or a response. 276 | readHangup :: Events e 277 | readHangup = Events #{const EPOLLRDHUP} 278 | 279 | -- | The @EPOLLET@ event. Only appears in requests. 280 | edgeTriggered :: Events Request 281 | edgeTriggered = Events #{const EPOLLET} 282 | 283 | -- | Does the first event set entirely contain the second one? That is, 284 | -- is the second argument a subset of the first? 285 | containsAllEvents :: Events e -> Events e -> Bool 286 | containsAllEvents (Events a) (Events b) = a .&. b == b 287 | 288 | -- | Does the first event set contain any of the events from the second one? 289 | containsAnyEvents :: Events e -> Events e -> Bool 290 | containsAnyEvents (Events a) (Events b) = (a .&. b) /= 0 291 | 292 | sizeofEvent :: Int 293 | sizeofEvent = #{size struct epoll_event} 294 | 295 | -- | Read @events@ from @struct epoll_event@. 296 | peekEventEvents :: Addr -> IO (Events e) 297 | peekEventEvents (Addr p) = #{peek struct epoll_event, events} (Ptr p) 298 | 299 | -- | Read @data.fd@ from @struct epoll_event@. 300 | peekEventDataFd :: Addr -> IO Fd 301 | peekEventDataFd (Addr p) = #{peek struct epoll_event, data.fd} (Ptr p) 302 | 303 | -- | Read @data.ptr@ from @struct epoll_event@. 304 | peekEventDataPtr :: Addr -> IO Addr 305 | peekEventDataPtr (Addr p) = do 306 | Ptr q <- #{peek struct epoll_event, data.ptr} (Ptr p) 307 | pure (Addr q) 308 | 309 | -- | Read @data.u32@ from @struct epoll_event@. 310 | peekEventDataU32 :: Addr -> IO Word32 311 | peekEventDataU32 (Addr p) = #{peek struct epoll_event, data.u32} (Ptr p) 312 | 313 | -- | Read @data.u64@ from @struct epoll_event@. 314 | peekEventDataU64 :: Addr -> IO Word64 315 | peekEventDataU64 (Addr p) = #{peek struct epoll_event, data.u64} (Ptr p) 316 | 317 | -- | Write @data.u64@ from @struct epoll_event@. 318 | pokeEventDataU64 :: Addr -> Word64 -> IO () 319 | pokeEventDataU64 (Addr p) w = #{poke struct epoll_event, data.u64} (Ptr p) w 320 | 321 | composePayload :: Word32 -> Word32 -> Word64 322 | {-# inline composePayload #-} 323 | composePayload a b = unsafeShiftL (word32ToWord64 a) 32 .|. word32ToWord64 b 324 | 325 | decomposePayload :: Word64 -> (Word32,Word32) 326 | {-# inline decomposePayload #-} 327 | decomposePayload w = (word64ToWord32 (unsafeShiftR w 32), word64ToWord32 w) 328 | 329 | word32ToWord64 :: Word32 -> Word64 330 | word32ToWord64 = fromIntegral 331 | 332 | word64ToWord32 :: Word64 -> Word32 333 | word64ToWord32 = fromIntegral 334 | 335 | unI :: Int -> Int## 336 | unI (I## i) = i 337 | -------------------------------------------------------------------------------- /src/Posix/File.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE BinaryLiterals #-} 3 | {-# LANGUAGE MagicHash #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE UnliftedFFITypes #-} 6 | 7 | module Posix.File 8 | ( -- * Functions 9 | uninterruptibleGetDescriptorFlags 10 | , uninterruptibleGetStatusFlags 11 | , uninterruptibleWriteByteArray 12 | , uninterruptibleWriteBytes 13 | , uninterruptibleWriteBytesCompletely 14 | , uninterruptibleWriteBytesCompletelyErrno 15 | , uninterruptibleReadMutableByteArray 16 | , writeBytesCompletelyErrno 17 | , uninterruptibleOpen 18 | , uninterruptibleOpenMode 19 | , uninterruptibleOpenAtMode 20 | , uninterruptibleOpenUntypedFlags 21 | , uninterruptibleOpenModeUntypedFlags 22 | , uninterruptibleRenameAt 23 | , writeByteArray 24 | , writeMutableByteArray 25 | , close 26 | , uninterruptibleClose 27 | , uninterruptibleErrorlessClose 28 | , uninterruptibleUnlink 29 | , uninterruptibleLink 30 | 31 | -- * Types 32 | , AccessMode (..) 33 | , CreationFlags (..) 34 | , DescriptorFlags (..) 35 | , StatusFlags (..) 36 | 37 | -- * File Descriptor Flags 38 | , Types.nonblocking 39 | , Types.append 40 | , isReadOnly 41 | , isWriteOnly 42 | , isReadWrite 43 | 44 | -- * Open Access Mode 45 | , Types.readOnly 46 | , Types.writeOnly 47 | , Types.readWrite 48 | 49 | -- * File Creation Flags 50 | , Types.create 51 | , Types.truncate 52 | , Types.exclusive 53 | ) where 54 | 55 | import Assertion (assertByteArrayPinned, assertMutableByteArrayPinned) 56 | import Data.Bits ((.&.), (.|.)) 57 | import Data.Bytes.Types (Bytes (Bytes)) 58 | import Data.Primitive (ByteArray (..), MutableByteArray (MutableByteArray)) 59 | import Foreign.C.Error (Errno (Errno), eOK, getErrno) 60 | import Foreign.C.String.Managed (ManagedCString (..)) 61 | import Foreign.C.Types (CInt (..), CSize (..)) 62 | import GHC.Exts (ByteArray#, MutableByteArray#, RealWorld) 63 | import Posix.File.Types (AccessMode (..), CreationFlags (..), DescriptorFlags (..), StatusFlags (..)) 64 | import System.Posix.Types (CMode (..), CSsize (..), Fd (..)) 65 | 66 | import qualified Posix.File.Types as Types 67 | 68 | {- | Get file descriptor flags. This uses the unsafe FFI to 69 | perform @fcntl(fd,F_GETFD)@. 70 | -} 71 | uninterruptibleGetDescriptorFlags :: Fd -> IO (Either Errno DescriptorFlags) 72 | uninterruptibleGetDescriptorFlags !fd = c_getFdFlags fd >>= errorsFromDescriptorFlags 73 | 74 | {- | Get file status flags. This uses the unsafe FFI to 75 | perform @fcntl(fd,F_GETFL)@. 76 | -} 77 | uninterruptibleGetStatusFlags :: Fd -> IO (Either Errno StatusFlags) 78 | uninterruptibleGetStatusFlags !fd = c_getFlFlags fd >>= errorsFromStatusFlags 79 | 80 | foreign import ccall unsafe "HaskellPosix.h hs_get_fd_flags" 81 | c_getFdFlags :: Fd -> IO DescriptorFlags 82 | 83 | foreign import ccall unsafe "HaskellPosix.h hs_get_fl_flags" 84 | c_getFlFlags :: Fd -> IO StatusFlags 85 | 86 | foreign import ccall unsafe "HaskellPosix.h write_offset" 87 | c_unsafe_bytearray_write :: Fd -> ByteArray# -> Int -> CSize -> IO CSsize 88 | 89 | foreign import ccall unsafe "HaskellPosix.h write_offset_loop" 90 | c_unsafe_bytearray_write_loop :: Fd -> ByteArray# -> Int -> CSize -> IO Errno 91 | 92 | foreign import ccall safe "HaskellPosix.h write_offset_loop" 93 | c_safe_bytearray_write_loop :: Fd -> ByteArray# -> Int -> CSize -> IO Errno 94 | 95 | foreign import ccall safe "HaskellPosix.h write_offset" 96 | c_safe_bytearray_write :: Fd -> ByteArray# -> Int -> CSize -> IO CSsize 97 | 98 | foreign import ccall safe "HaskellPosix.h write_offset" 99 | c_safe_mutablebytearray_write :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> IO CSsize 100 | 101 | foreign import ccall unsafe "HaskellPosix.h open" 102 | c_unsafe_open :: ByteArray# -> CInt -> IO Fd 103 | 104 | foreign import ccall unsafe "HaskellPosix.h renameat" 105 | c_unsafe_rename_at :: Fd -> ByteArray# -> Fd -> ByteArray# -> IO CInt 106 | 107 | foreign import ccall unsafe "HaskellPosix.h open" 108 | c_unsafe_open_mode :: ByteArray# -> CInt -> CMode -> IO Fd 109 | 110 | foreign import ccall unsafe "HaskellPosix.h openat" 111 | c_unsafe_openat_mode :: Fd -> ByteArray# -> CInt -> CMode -> IO Fd 112 | 113 | foreign import ccall unsafe "HaskellPosix.h unlink" 114 | c_unsafe_unlink :: ByteArray# -> IO CInt 115 | 116 | foreign import ccall unsafe "HaskellPosix.h link" 117 | c_unsafe_link :: ByteArray# -> ByteArray# -> IO CInt 118 | 119 | foreign import ccall safe "unistd.h close" 120 | c_safe_close :: Fd -> IO CInt 121 | 122 | foreign import ccall unsafe "unistd.h close" 123 | c_unsafe_close :: Fd -> IO CInt 124 | 125 | -- | Rename a file. This is a wrapper around the POSIX function @renameat@. 126 | uninterruptibleRenameAt :: 127 | -- | Old dir fd 128 | Fd 129 | -- | Old file name 130 | -> ManagedCString 131 | -- | New dir fd 132 | -> Fd 133 | -- | New file name 134 | -> ManagedCString 135 | -> IO (Either Errno ()) 136 | uninterruptibleRenameAt !oldDirFd (ManagedCString (ByteArray oldName)) !newDirFd (ManagedCString (ByteArray newName)) = 137 | c_unsafe_rename_at oldDirFd oldName newDirFd newName >>= errorsFromInt_ 138 | 139 | uninterruptibleOpen :: 140 | -- | NULL-terminated file name 141 | ManagedCString -> 142 | -- | Access mode 143 | AccessMode -> 144 | -- | Creation flags 145 | CreationFlags -> 146 | -- | Status flags 147 | StatusFlags -> 148 | IO (Either Errno Fd) 149 | uninterruptibleOpen (ManagedCString (ByteArray name)) (AccessMode x) (CreationFlags y) (StatusFlags z) = 150 | c_unsafe_open name (x .|. y .|. z) >>= errorsFromFd 151 | 152 | {- | Variant of 'uninterruptibleOpen' that does not help the caller with 153 | the types of the flags. 154 | -} 155 | uninterruptibleOpenUntypedFlags :: 156 | -- | NULL-terminated file name 157 | ManagedCString -> 158 | -- | Flags 159 | CInt -> 160 | IO (Either Errno Fd) 161 | uninterruptibleOpenUntypedFlags (ManagedCString (ByteArray name)) x = 162 | c_unsafe_open name x >>= errorsFromFd 163 | 164 | {- | Variant of 'uninterruptibleOpenMode' that does not help the caller with 165 | the types of the flags. 166 | -} 167 | uninterruptibleOpenModeUntypedFlags :: 168 | -- | NULL-terminated file name 169 | ManagedCString -> 170 | -- | Flags 171 | CInt -> 172 | -- | Mode 173 | CMode -> 174 | IO (Either Errno Fd) 175 | uninterruptibleOpenModeUntypedFlags (ManagedCString (ByteArray name)) !x !mode = 176 | c_unsafe_open_mode name x mode >>= errorsFromFd 177 | 178 | uninterruptibleOpenMode :: 179 | -- | NULL-terminated file name 180 | ManagedCString -> 181 | -- | Access mode, should include @O_CREAT@ 182 | AccessMode -> 183 | -- | Creation flags 184 | CreationFlags -> 185 | -- | Status flags 186 | StatusFlags -> 187 | -- | Permissions assigned to newly created file 188 | CMode -> 189 | IO (Either Errno Fd) 190 | uninterruptibleOpenMode (ManagedCString (ByteArray name)) (AccessMode x) (CreationFlags y) (StatusFlags z) !mode = 191 | c_unsafe_open_mode name (x .|. y .|. z) mode >>= errorsFromFd 192 | 193 | {- | Variant of 'uninterruptibleOpenMode' that lets the user specify a 194 | directory file descriptor instead of using the working directory as the 195 | base path. 196 | -} 197 | uninterruptibleOpenAtMode :: 198 | -- | Base directory 199 | Fd -> 200 | -- | NULL-terminated file name 201 | ManagedCString -> 202 | -- | Access mode, should include @O_CREAT@ 203 | AccessMode -> 204 | -- | Creation flags 205 | CreationFlags -> 206 | -- | Status flags 207 | StatusFlags -> 208 | -- | Permissions assigned to newly created file 209 | CMode -> 210 | IO (Either Errno Fd) 211 | uninterruptibleOpenAtMode !dirFd (ManagedCString (ByteArray name)) (AccessMode x) (CreationFlags y) (StatusFlags z) !mode = 212 | c_unsafe_openat_mode dirFd name (x .|. y .|. z) mode >>= errorsFromFd 213 | 214 | errorsFromDescriptorFlags :: DescriptorFlags -> IO (Either Errno DescriptorFlags) 215 | errorsFromDescriptorFlags r@(DescriptorFlags x) = 216 | if x > (-1) 217 | then pure (Right r) 218 | else fmap Left getErrno 219 | 220 | errorsFromStatusFlags :: StatusFlags -> IO (Either Errno StatusFlags) 221 | errorsFromStatusFlags r@(StatusFlags x) = 222 | if x > (-1) 223 | then pure (Right r) 224 | else fmap Left getErrno 225 | 226 | {- | Wrapper for @write(2)@ that takes a slice of bytes and an offset. 227 | The byte array backing the slice does not need to be pinned. 228 | -} 229 | uninterruptibleWriteBytesCompletely :: 230 | -- | File descriptor 231 | Fd -> 232 | -- | Source bytes 233 | Bytes -> 234 | IO (Either Errno ()) 235 | uninterruptibleWriteBytesCompletely !fd !b = do 236 | e <- uninterruptibleWriteBytesCompletelyErrno fd b 237 | if e == eOK 238 | then pure (Right ()) 239 | else pure (Left e) 240 | 241 | {- | Variant of 'uninterruptibleWriteBytesCompletely' that uses errno 0 242 | to communicate success. 243 | -} 244 | uninterruptibleWriteBytesCompletelyErrno :: 245 | -- | File descriptor 246 | Fd -> 247 | -- | Source bytes 248 | Bytes -> 249 | IO Errno 250 | uninterruptibleWriteBytesCompletelyErrno !fd (Bytes (ByteArray buf) off len) = 251 | c_unsafe_bytearray_write_loop fd buf off (fromIntegral @Int @CSize len) 252 | 253 | {- | Wrapper for @write(2)@ that takes a slice of bytes and an offset. 254 | The byte array backing the slice must be pinned. 255 | -} 256 | writeBytesCompletelyErrno :: 257 | -- | File descriptor 258 | Fd -> 259 | -- | Source bytes 260 | Bytes -> 261 | IO Errno 262 | writeBytesCompletelyErrno !fd (Bytes buf0 off len) = 263 | let !(ByteArray buf1) = assertByteArrayPinned buf0 264 | in c_safe_bytearray_write_loop fd buf1 off (fromIntegral @Int @CSize len) 265 | 266 | {- | Wrapper for @write(2)@ that takes a slice of bytes and an offset. 267 | The byte array backing the slice does not need to be pinned. 268 | -} 269 | uninterruptibleWriteBytes :: 270 | -- | File descriptor 271 | Fd -> 272 | -- | Source bytes 273 | Bytes -> 274 | -- | Number of bytes written 275 | IO (Either Errno CSize) 276 | uninterruptibleWriteBytes !fd (Bytes (ByteArray buf) off len) = 277 | c_unsafe_bytearray_write fd buf off (fromIntegral @Int @CSize len) 278 | >>= errorsFromSize 279 | 280 | {- | Wrapper for @write(2)@ that takes a byte array and an offset. 281 | The byte array does not need to be pinned. 282 | -} 283 | uninterruptibleWriteByteArray :: 284 | -- | Socket 285 | Fd -> 286 | -- | Source byte array 287 | ByteArray -> 288 | -- | Offset into source array 289 | Int -> 290 | -- | Length in bytes 291 | CSize -> 292 | -- | Number of bytes pushed to send buffer 293 | IO (Either Errno CSize) 294 | uninterruptibleWriteByteArray !fd (ByteArray buf) !off !len = 295 | c_unsafe_bytearray_write fd buf off len >>= errorsFromSize 296 | 297 | {- | Wrapper for @write(2)@ that takes a byte array and an offset. 298 | Uses @safe@ FFI. The byte array must be pinned. 299 | -} 300 | writeByteArray :: 301 | -- | File descriptor 302 | Fd -> 303 | -- | Source byte array 304 | ByteArray -> 305 | -- | Offset into source array 306 | Int -> 307 | -- | Length in bytes 308 | CSize -> 309 | -- | Number of bytes pushed to send buffer 310 | IO (Either Errno CSize) 311 | writeByteArray !fd !buf0 !off !len = 312 | let !(ByteArray buf1) = assertByteArrayPinned buf0 313 | in c_safe_bytearray_write fd buf1 off len >>= errorsFromSize 314 | 315 | -- writeByteArrayCompletely :: 316 | 317 | {- | Variant of 'writeByteArray' that operates on mutable byte array. 318 | Uses @safe@ FFI. The byte array must be pinned. 319 | -} 320 | writeMutableByteArray :: 321 | -- | File descriptor 322 | Fd -> 323 | -- | Source byte array 324 | MutableByteArray RealWorld -> 325 | -- | Offset into source array 326 | Int -> 327 | -- | Length in bytes 328 | CSize -> 329 | -- | Number of bytes pushed to send buffer 330 | IO (Either Errno CSize) 331 | writeMutableByteArray !fd !buf0 !off !len = 332 | let !(MutableByteArray buf1) = assertMutableByteArrayPinned buf0 333 | in c_safe_mutablebytearray_write fd buf1 off len >>= errorsFromSize 334 | 335 | uninterruptibleReadMutableByteArray :: 336 | -- | File descriptor 337 | Fd -> 338 | -- | Destination 339 | MutableByteArray RealWorld -> 340 | -- | Destination offset 341 | Int -> 342 | -- | Length in bytes 343 | CSize -> 344 | -- | Number of bytes received 345 | IO (Either Errno CSize) 346 | uninterruptibleReadMutableByteArray !fd !(MutableByteArray !b) !doff !dlen = do 347 | c_unsafe_mutable_byte_array_read fd b doff dlen >>= errorsFromSize 348 | 349 | errorsFromSize :: CSsize -> IO (Either Errno CSize) 350 | errorsFromSize r = 351 | if r > (-1) 352 | then pure (Right (cssizeToCSize r)) 353 | else fmap Left getErrno 354 | 355 | errorsFromFd :: Fd -> IO (Either Errno Fd) 356 | errorsFromFd r = 357 | if r > (-1) 358 | then pure (Right r) 359 | else fmap Left getErrno 360 | 361 | uninterruptibleLink :: 362 | -- | Path to existing file 363 | ManagedCString -> 364 | -- | Path to new file 365 | ManagedCString -> 366 | IO (Either Errno ()) 367 | uninterruptibleLink (ManagedCString (ByteArray x)) (ManagedCString (ByteArray y)) = 368 | c_unsafe_link x y >>= errorsFromInt_ 369 | 370 | uninterruptibleUnlink :: 371 | -- | File name 372 | ManagedCString -> 373 | IO (Either Errno ()) 374 | uninterruptibleUnlink (ManagedCString (ByteArray x)) = 375 | c_unsafe_unlink x >>= errorsFromInt_ 376 | 377 | {- | Close a file descriptor. 378 | The 379 | includes more details. This uses the safe FFI. 380 | -} 381 | close :: 382 | -- | Socket 383 | Fd -> 384 | IO (Either Errno ()) 385 | close fd = c_safe_close fd >>= errorsFromInt_ 386 | 387 | {- | Close a file descriptor. This uses the unsafe FFI. According to the 388 | , 389 | "If @fildes@ refers to a socket, @close()@ shall cause the socket to 390 | be destroyed. If the socket is in connection-mode, and the @SO_LINGER@ 391 | option is set for the socket with non-zero linger time, and the socket 392 | has untransmitted data, then @close()@ shall block for up to the current 393 | linger interval until all data is transmitted." 394 | -} 395 | uninterruptibleClose :: 396 | -- | Socket 397 | Fd -> 398 | IO (Either Errno ()) 399 | uninterruptibleClose fd = c_unsafe_close fd >>= errorsFromInt_ 400 | 401 | {- | Close a file descriptor with the unsafe FFI. Do not check for errors. 402 | It is only appropriate to use this when a file descriptor is being 403 | closed to handle an exceptional case. Since the user will want to 404 | propogate the original exception, the exception provided by 405 | 'uninterruptibleClose' would just be discarded. This function allows us 406 | to potentially avoid an additional FFI call to 'getErrno'. 407 | -} 408 | uninterruptibleErrorlessClose :: 409 | -- | Socket 410 | Fd -> 411 | IO () 412 | uninterruptibleErrorlessClose fd = do 413 | _ <- c_unsafe_close fd 414 | pure () 415 | 416 | -- only call this when it is known that the argument is non-negative 417 | cssizeToCSize :: CSsize -> CSize 418 | cssizeToCSize = fromIntegral 419 | 420 | isReadOnly :: StatusFlags -> Bool 421 | isReadOnly (StatusFlags x) = x .&. 0b11 == 0 422 | 423 | isWriteOnly :: StatusFlags -> Bool 424 | isWriteOnly (StatusFlags x) = x .&. 0b11 == 1 425 | 426 | isReadWrite :: StatusFlags -> Bool 427 | isReadWrite (StatusFlags x) = x .&. 0b11 == 2 428 | 429 | -- Sometimes, functions that return an int use zero to indicate 430 | -- success and negative one to indicate failure without including 431 | -- additional information in the value. 432 | errorsFromInt_ :: CInt -> IO (Either Errno ()) 433 | errorsFromInt_ r = 434 | if r == 0 435 | then pure (Right ()) 436 | else fmap Left getErrno 437 | 438 | foreign import ccall unsafe "HaskellPosix.h read_offset" 439 | c_unsafe_mutable_byte_array_read :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> IO CSsize 440 | -------------------------------------------------------------------------------- /src/Posix/Socket/Types.hsc: -------------------------------------------------------------------------------- 1 | {-# language DataKinds #-} 2 | {-# language DerivingStrategies #-} 3 | {-# language DuplicateRecordFields #-} 4 | {-# language GADTSyntax #-} 5 | {-# language GeneralizedNewtypeDeriving #-} 6 | {-# language KindSignatures #-} 7 | {-# language MagicHash #-} 8 | {-# language PatternSynonyms #-} 9 | {-# language UnboxedTuples #-} 10 | {-# language NamedFieldPuns #-} 11 | 12 | -- This is needed because hsc2hs does not currently handle ticked 13 | -- promoted data constructors correctly. 14 | {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} 15 | 16 | #include 17 | #include 18 | #include 19 | #include "custom.h" 20 | 21 | -- | All of the data constructors provided by this module are unsafe. 22 | -- Only use them if you really know what you are doing. 23 | module Posix.Socket.Types 24 | ( Family(..) 25 | , Type(..) 26 | , Protocol(..) 27 | , Level(..) 28 | , OptionName(..) 29 | , OptionValue(..) 30 | , SocketAddress(..) 31 | , SocketAddressInternet(..) 32 | , SocketAddressInternet6(..) 33 | , SocketAddressUnix(..) 34 | , MessageFlags(..) 35 | , Message(..) 36 | , ShutdownType(..) 37 | , AddressInfoFlags(..) 38 | -- * Phantom Types 39 | , AddressInfo 40 | -- * Socket Families 41 | , pattern Unix 42 | , pattern Unspecified 43 | , pattern Internet 44 | , pattern Internet6 45 | -- * Socket Types 46 | , stream 47 | , datagram 48 | , raw 49 | , sequencedPacket 50 | -- * Protocols 51 | , defaultProtocol 52 | , rawProtocol 53 | , icmp 54 | , tcp 55 | , udp 56 | , ip 57 | , ipv6 58 | -- * Receive Flags 59 | , peek 60 | , outOfBand 61 | , waitAll 62 | -- * Send Flags 63 | , noSignal 64 | -- * Shutdown Types 65 | , read 66 | , write 67 | , readWrite 68 | -- * Socket Levels 69 | , levelSocket 70 | -- * Option Names 71 | , optionError 72 | , bindToDevice 73 | , broadcast 74 | , reuseAddress 75 | -- * AddressInfo 76 | -- ** Peek 77 | , peekAddressInfoFlags 78 | , peekAddressInfoFamily 79 | , peekAddressInfoSocketType 80 | , peekAddressInfoProtocol 81 | , peekAddressInfoAddressLength 82 | , peekAddressInfoAddress 83 | , peekAddressInfoNext 84 | -- ** Poke 85 | , pokeAddressInfoFlags 86 | , pokeAddressInfoFamily 87 | , pokeAddressInfoSocketType 88 | , pokeAddressInfoProtocol 89 | -- ** Metadata 90 | , sizeofAddressInfo 91 | -- * Message Header 92 | -- ** Peek 93 | , peekMessageHeaderName 94 | , peekMessageHeaderNameLength 95 | , peekMessageHeaderIOVector 96 | , peekMessageHeaderIOVectorLength 97 | , peekMessageHeaderControl 98 | , peekMessageHeaderControlLength 99 | , peekMessageHeaderFlags 100 | , peekControlMessageHeaderLevel 101 | , peekControlMessageHeaderLength 102 | , peekControlMessageHeaderType 103 | -- ** Poke 104 | , pokeMessageHeaderName 105 | , pokeMessageHeaderNameLength 106 | , pokeMessageHeaderIOVector 107 | , pokeMessageHeaderIOVectorLength 108 | , pokeMessageHeaderControl 109 | , pokeMessageHeaderControlLength 110 | , pokeMessageHeaderFlags 111 | -- ** Metadata 112 | , sizeofMessageHeader 113 | -- * IO Vector 114 | -- ** Peek 115 | , peekIOVectorBase 116 | , peekIOVectorLength 117 | -- ** Poke 118 | , pokeIOVectorBase 119 | , pokeIOVectorLength 120 | -- ** Metadata 121 | , sizeofIOVector 122 | ) where 123 | 124 | import Prelude hiding (read) 125 | 126 | import Data.Bits (Bits,(.|.)) 127 | import Data.Primitive (ByteArray,Prim(..)) 128 | import Data.Primitive.Addr (Addr(..)) 129 | import Data.Word (Word16,Word32,Word64) 130 | import Foreign.C.Types (CInt(..),CSize) 131 | import Foreign.Storable (Storable,peekByteOff,pokeByteOff) 132 | import GHC.Ptr (Ptr(..)) 133 | import GHC.Exts (Int(I##),Int##,(*##),(+##)) 134 | 135 | import qualified Data.Kind 136 | import qualified Data.Primitive as PM 137 | 138 | -- | Phantom for pointers to @addrinfo@ in address resolution functions. 139 | -- According to POSIX: 140 | -- 141 | -- > struct addrinfo { 142 | -- > int ai_flags; 143 | -- > int ai_family; 144 | -- > int ai_socktype; 145 | -- > int ai_protocol; 146 | -- > socklen_t ai_addrlen; 147 | -- > struct sockaddr *ai_addr; 148 | -- > char *ai_canonname; 149 | -- > struct addrinfo *ai_next; 150 | -- > }; 151 | data AddressInfo 152 | 153 | -- | A socket communications domain, sometimes referred to as a family. The spec 154 | -- mandates @AF_UNIX@, @AF_UNSPEC@, and @AF_INET@. 155 | newtype Family = Family CInt 156 | deriving newtype (Storable) 157 | 158 | -- | A socket type. The spec mandates @SOCK_STREAM@, @SOCK_DGRAM@, 159 | -- and @SOCK_SEQPACKET@. Other types may be available on a per-platform 160 | -- basis. 161 | -- 162 | -- TODO: Change this to SocketType 163 | newtype Type = Type CInt 164 | deriving newtype (Storable) 165 | 166 | newtype Protocol = Protocol { getProtocol :: CInt } 167 | deriving newtype (Storable) 168 | 169 | newtype Level = Level CInt 170 | 171 | -- | Options used in the @option_name@ argument in @getsockopt@ 172 | -- or @setsockopt@. 173 | newtype OptionName = OptionName CInt 174 | 175 | -- | Which end of the socket to shutdown. 176 | newtype ShutdownType = ShutdownType CInt 177 | 178 | -- | The direction of a message. The data constructor are only used 179 | -- at the type level as phantom arguments. 180 | data Message = Send | Receive 181 | 182 | -- | Receive flags are given by @MessageFlags Receive@ and send flags 183 | -- are given by @MessageFlags Send@. This is done because there are 184 | -- several flags that are applicable in either a receiving 185 | -- context or a sending context. 186 | newtype MessageFlags :: Message -> Data.Kind.Type where 187 | MessageFlags :: CInt -> MessageFlags m 188 | deriving stock (Eq) 189 | deriving newtype (Bits) 190 | 191 | instance Semigroup (MessageFlags m) where (<>) = (.|.) 192 | instance Monoid (MessageFlags m) where mempty = MessageFlags 0 193 | 194 | newtype AddressInfoFlags = AddressInfoFlags CInt 195 | deriving newtype (Eq,Storable) 196 | 197 | instance Semigroup AddressInfoFlags where 198 | AddressInfoFlags x <> AddressInfoFlags y = AddressInfoFlags (x .|. y) 199 | instance Monoid AddressInfoFlags where mempty = AddressInfoFlags 0 200 | 201 | -- | The @sockaddr@ data. This is an extensible tagged union, so this library 202 | -- has chosen to represent it as byte array. It is up to platform-specific 203 | -- libraries to inhabit this type with values. The byte array backing this 204 | -- may be unpinned or pinned. 205 | newtype SocketAddress = SocketAddress ByteArray 206 | deriving newtype (Eq,Show) 207 | 208 | -- | The @option_value@ data. 209 | newtype OptionValue = OptionValue ByteArray 210 | 211 | -- | An address for an Internet socket over IPv4. The 212 | -- 213 | -- mandates three fields: 214 | -- 215 | -- > sa_family_t sin_family AF_INET 216 | -- > in_port_t sin_port Port number 217 | -- > struct in_addr sin_addr IP address 218 | -- 219 | -- This type omits the first field since is a constant that 220 | -- is only relevant for serialization purposes. The spec also 221 | -- mandates that @sin_port@ and @sin_addr@ be in network 222 | -- byte order, so keep in mind that these values are not 223 | -- immidiately useable. 224 | data SocketAddressInternet = SocketAddressInternet 225 | { port :: !Word16 226 | , address :: !Word32 227 | } deriving (Eq,Show) 228 | 229 | -- | The index and read functions ignore @sin_family@. The write functions 230 | -- will set @sin_family@ to @AF_INET@. 231 | instance Prim SocketAddressInternet where 232 | sizeOf## _ = unI #{size struct sockaddr_in} 233 | alignment## _ = PM.alignment## (undefined :: Word) 234 | indexByteArray## arr i = SocketAddressInternet 235 | { port = #{indexByteArrayHash struct sockaddr_in, sin_port} arr i 236 | , address = #{indexByteArrayHash struct sockaddr_in, sin_addr} arr i 237 | } 238 | indexOffAddr## arr i = SocketAddressInternet 239 | { port = #{indexOffAddrHash struct sockaddr_in, sin_port} arr i 240 | , address = #{indexOffAddrHash struct sockaddr_in, sin_addr} arr i 241 | } 242 | readByteArray## arr i s0 = 243 | case #{readByteArrayHash struct sockaddr_in, sin_port} arr i s0 of 244 | (## s1, port ##) -> case #{readByteArrayHash struct sockaddr_in, sin_addr} arr i s1 of 245 | (## s2, address ##) -> (## s2, SocketAddressInternet{port,address} ##) 246 | readOffAddr## arr i s0 = 247 | case #{readOffAddrHash struct sockaddr_in, sin_port} arr i s0 of 248 | (## s1, port ##) -> case #{readOffAddrHash struct sockaddr_in, sin_addr} arr i s1 of 249 | (## s2, address ##) -> (## s2, SocketAddressInternet{port,address} ##) 250 | writeByteArray## arr i SocketAddressInternet{port,address} s0 = 251 | case #{writeByteArrayHash struct sockaddr_in, sin_family} arr i (#{const AF_INET} :: #{type sa_family_t}) s0 of 252 | s1 -> case #{writeByteArrayHash struct sockaddr_in, sin_port} arr i port s1 of 253 | s2 -> #{writeByteArrayHash struct sockaddr_in, sin_addr} arr i address s2 254 | writeOffAddr## arr i SocketAddressInternet{port,address} s0 = 255 | case #{writeOffAddrHash struct sockaddr_in, sin_family} arr i (#{const AF_INET} :: #{type sa_family_t}) s0 of 256 | s1 -> case #{writeOffAddrHash struct sockaddr_in, sin_port} arr i port s1 of 257 | s2 -> #{writeOffAddrHash struct sockaddr_in, sin_addr} arr i address s2 258 | setByteArray## = PM.defaultSetByteArray## 259 | setOffAddr## = PM.defaultSetOffAddr## 260 | 261 | -- Revisit this. We really need a standard Word128 type somewhere. 262 | -- Solution: use the wideword package. 263 | data SocketAddressInternet6 = SocketAddressInternet6 264 | { port :: !Word16 265 | , flowInfo :: !Word32 266 | , addressA :: !Word64 267 | , addressB :: !Word64 268 | , scopeId :: !Word32 269 | } 270 | 271 | -- | An address for a UNIX domain socket. The 272 | -- 273 | -- mandates two fields: 274 | -- 275 | -- > sa_family_t sun_family Address family. 276 | -- > char sun_path[] Socket pathname. 277 | -- 278 | -- However, the first field is omitted since it is always @AF_UNIX@. 279 | -- It is adding during serialization. Although @sun_path@ is a 280 | -- null-terminated string, @SocketAddressUnix@ should not have 281 | -- a trailing null byte. The conversion function @encodeSocketAddressUnix@ 282 | -- adds the null terminator. The size of path should not equal 283 | -- or exceed the platform-dependent size of @sun_path@. 284 | newtype SocketAddressUnix = SocketAddressUnix 285 | { path :: ByteArray 286 | } 287 | 288 | -- | The @SOCK_STREAM@ socket type. 289 | stream :: Type 290 | stream = Type #{const SOCK_STREAM} 291 | 292 | -- | The @SOCK_DGRAM@ socket type. 293 | datagram :: Type 294 | datagram = Type #{const SOCK_DGRAM} 295 | 296 | -- | The @SOCK_RAW@ socket type. POSIX declares raw sockets optional. 297 | -- However, they are included here for convenience. Please open an 298 | -- issue if this prevents this library from compiling on a 299 | -- POSIX-compliant operating system that anyone uses for haskell 300 | -- development. Keep in mind that even though raw sockets may exist 301 | -- on all POSIX-compliant operating systems, they may differ in 302 | -- their behavior. 303 | raw :: Type 304 | raw = Type #{const SOCK_RAW} 305 | 306 | -- | The @SOCK_SEQPACKET@ socket type. 307 | sequencedPacket :: Type 308 | sequencedPacket = Type #{const SOCK_SEQPACKET} 309 | 310 | -- | The @AF_UNIX@ communications domain. 311 | pattern Unix :: Family 312 | pattern Unix = Family #{const AF_UNIX} 313 | 314 | -- | The @AF_UNSPEC@ communications domain. 315 | pattern Unspecified :: Family 316 | pattern Unspecified = Family #{const AF_UNSPEC} 317 | 318 | -- | The @AF_INET@ communications domain. 319 | pattern Internet :: Family 320 | pattern Internet = Family #{const AF_INET} 321 | 322 | -- | The @AF_INET6@ communications domain. POSIX declares raw sockets 323 | -- optional. However, they are included here for convenience. Please 324 | -- open an issue if this prevents this library from compiling on a 325 | -- POSIX-compliant operating system that anyone uses for haskell 326 | -- development. 327 | pattern Internet6 :: Family 328 | pattern Internet6 = Family #{const AF_INET6} 329 | 330 | -- | The @MSG_OOB@ receive flag or send flag. 331 | outOfBand :: MessageFlags m 332 | outOfBand = MessageFlags #{const MSG_OOB} 333 | 334 | -- | The @MSG_PEEK@ receive flag. 335 | peek :: MessageFlags Receive 336 | peek = MessageFlags #{const MSG_PEEK} 337 | 338 | -- | The @MSG_WAITALL@ receive flag. 339 | waitAll :: MessageFlags Receive 340 | waitAll = MessageFlags #{const MSG_WAITALL} 341 | 342 | -- | The @MSG_NOSIGNAL@ send flag. 343 | noSignal :: MessageFlags Send 344 | noSignal = MessageFlags #{const MSG_NOSIGNAL} 345 | 346 | -- | The default protocol for a socket type. 347 | defaultProtocol :: Protocol 348 | defaultProtocol = Protocol 0 349 | 350 | -- | The @IPPROTO_RAW@ protocol. 351 | rawProtocol :: Protocol 352 | rawProtocol = Protocol #{const IPPROTO_RAW} 353 | 354 | -- | The @IPPROTO_ICMP@ protocol. 355 | icmp :: Protocol 356 | icmp = Protocol #{const IPPROTO_ICMP} 357 | 358 | -- | The @IPPROTO_TCP@ protocol. 359 | tcp :: Protocol 360 | tcp = Protocol #{const IPPROTO_TCP} 361 | 362 | -- | The @IPPROTO_UDP@ protocol. 363 | udp :: Protocol 364 | udp = Protocol #{const IPPROTO_UDP} 365 | 366 | -- | The @IPPROTO_IP@ protocol. 367 | ip :: Protocol 368 | ip = Protocol #{const IPPROTO_IP} 369 | 370 | -- | The @IPPROTO_IPV6@ protocol. 371 | ipv6 :: Protocol 372 | ipv6 = Protocol #{const IPPROTO_IPV6} 373 | 374 | -- | Disable further receive operations (e.g. @SHUT_RD@) 375 | read :: ShutdownType 376 | read = ShutdownType #{const SHUT_RD} 377 | 378 | -- | Disable further send operations (e.g. @SHUT_WR@) 379 | write :: ShutdownType 380 | write = ShutdownType #{const SHUT_WR} 381 | 382 | -- | Disable further send operations (e.g. @SHUT_RDWR@) 383 | readWrite :: ShutdownType 384 | readWrite = ShutdownType #{const SHUT_RDWR} 385 | 386 | -- | Socket error status (e.g. @SOL_SOCKET@) 387 | levelSocket :: Level 388 | levelSocket = Level #{const SOL_SOCKET} 389 | 390 | -- | Socket error status (e.g. @SO_ERROR@) 391 | optionError :: OptionName 392 | optionError = OptionName #{const SO_ERROR} 393 | 394 | -- | Bind to device (e.g. @SO_BINDTODEVICE@) 395 | bindToDevice :: OptionName 396 | bindToDevice = OptionName #{const SO_BINDTODEVICE} 397 | 398 | -- | Allow reuse of local address (e.g. @SO_REUSEADDR@) 399 | reuseAddress :: OptionName 400 | reuseAddress = OptionName #{const SO_REUSEADDR} 401 | 402 | -- | Transmission of broadcast messages is supported (e.g. @SO_BROADCAST@) 403 | broadcast :: OptionName 404 | broadcast = OptionName #{const SO_BROADCAST} 405 | 406 | peekControlMessageHeaderLength :: Addr -> IO CInt 407 | peekControlMessageHeaderLength (Addr p) = #{peek struct cmsghdr, cmsg_len} (Ptr p) 408 | 409 | peekControlMessageHeaderLevel :: Addr -> IO Level 410 | peekControlMessageHeaderLevel (Addr p) = do 411 | i <- #{peek struct cmsghdr, cmsg_level} (Ptr p) 412 | pure (Level i) 413 | 414 | -- | Get @cmsg_type@. 415 | peekControlMessageHeaderType :: Addr -> IO Type 416 | peekControlMessageHeaderType (Addr p) = do 417 | i <- #{peek struct cmsghdr, cmsg_type} (Ptr p) 418 | pure (Type i) 419 | 420 | -- Think about reintroducing this function when it becomes necessary. 421 | -- advanceControlMessageHeaderData :: Addr -> Addr 422 | -- advanceControlMessageHeaderData p = 423 | -- PM.plusAddr p (#{size struct cmsghdr}) 424 | 425 | -- | Get @iov_base@. 426 | peekIOVectorBase :: Addr -> IO Addr 427 | peekIOVectorBase (Addr p) = do 428 | Ptr x <- #{peek struct iovec, iov_base} (Ptr p) 429 | pure (Addr x) 430 | 431 | -- | Get @iov_len@. 432 | peekIOVectorLength :: Addr -> IO CSize 433 | peekIOVectorLength (Addr p) = #{peek struct iovec, iov_len} (Ptr p) 434 | 435 | -- | The size of a serialized @msghdr@. 436 | sizeofMessageHeader :: CInt 437 | sizeofMessageHeader = #{size struct msghdr} 438 | 439 | -- | Get @ai_flags@. 440 | peekAddressInfoFlags :: Ptr AddressInfo -> IO AddressInfoFlags 441 | peekAddressInfoFlags ptr = do 442 | x <- #{peek struct addrinfo, ai_flags} ptr 443 | pure (AddressInfoFlags x) 444 | 445 | -- | Set @ai_flags@. 446 | pokeAddressInfoFlags :: Ptr AddressInfo -> AddressInfoFlags -> IO () 447 | pokeAddressInfoFlags ptr (AddressInfoFlags x) = #{poke struct addrinfo, ai_flags} ptr x 448 | 449 | -- | Get @ai_family@. 450 | peekAddressInfoFamily :: Ptr AddressInfo -> IO Family 451 | peekAddressInfoFamily ptr = do 452 | x <- #{peek struct addrinfo, ai_family} ptr 453 | pure (Family x) 454 | 455 | -- | Get @ai_socktype@. 456 | peekAddressInfoSocketType :: Ptr AddressInfo -> IO Type 457 | peekAddressInfoSocketType ptr = do 458 | x <- #{peek struct addrinfo, ai_socktype} ptr 459 | pure (Type x) 460 | 461 | -- | Get @ai_protocol@. 462 | peekAddressInfoProtocol :: Ptr AddressInfo -> IO Protocol 463 | peekAddressInfoProtocol ptr = do 464 | x <- #{peek struct addrinfo, ai_protocol} ptr 465 | pure (Protocol x) 466 | 467 | -- | Get @ai_addrlen@. 468 | peekAddressInfoAddressLength :: Ptr AddressInfo -> IO CInt 469 | peekAddressInfoAddressLength ptr = #{peek struct addrinfo, ai_addrlen} ptr 470 | 471 | -- | Get @ai_addr@. 472 | peekAddressInfoAddress :: Ptr AddressInfo -> IO (Ptr SocketAddress) 473 | peekAddressInfoAddress ptr = #{peek struct addrinfo, ai_addr} ptr 474 | 475 | -- | Get @ai_next@. 476 | peekAddressInfoNext :: Ptr AddressInfo -> IO (Ptr AddressInfo) 477 | peekAddressInfoNext ptr = #{peek struct addrinfo, ai_next} ptr 478 | 479 | -- | Set @ai_family@. 480 | pokeAddressInfoFamily :: Ptr AddressInfo -> Family -> IO () 481 | pokeAddressInfoFamily ptr (Family x) = #{poke struct addrinfo, ai_family} ptr x 482 | 483 | -- | Set @ai_socktype@. 484 | pokeAddressInfoSocketType :: Ptr AddressInfo -> Type -> IO () 485 | pokeAddressInfoSocketType ptr (Type x) = #{poke struct addrinfo, ai_socktype} ptr x 486 | 487 | -- | Set @ai_protocol@. 488 | pokeAddressInfoProtocol :: Ptr AddressInfo -> Protocol -> IO () 489 | pokeAddressInfoProtocol ptr (Protocol x) = #{poke struct addrinfo, ai_protocol} ptr x 490 | 491 | -- | The size of a serialized @addrinfo@. 492 | sizeofAddressInfo :: Int 493 | sizeofAddressInfo = #{size struct addrinfo} 494 | 495 | -- | The size of a serialized @iovec@. 496 | sizeofIOVector :: CInt 497 | sizeofIOVector = #{size struct iovec} 498 | 499 | peekMessageHeaderName :: Addr -> IO Addr 500 | peekMessageHeaderName (Addr p) = do 501 | Ptr x <- #{peek struct msghdr, msg_name} (Ptr p) 502 | pure (Addr x) 503 | 504 | pokeMessageHeaderName :: Addr -> Addr -> IO () 505 | pokeMessageHeaderName (Addr p) (Addr x) = #{poke struct msghdr, msg_name} (Ptr p) (Ptr x) 506 | 507 | pokeMessageHeaderNameLength :: Addr -> CInt -> IO () 508 | pokeMessageHeaderNameLength (Addr p) = #{poke struct msghdr, msg_namelen} (Ptr p) 509 | 510 | pokeMessageHeaderIOVector :: Addr -> Addr -> IO () 511 | pokeMessageHeaderIOVector (Addr p) (Addr x) = #{poke struct msghdr, msg_iov} (Ptr p) (Ptr x) 512 | 513 | pokeMessageHeaderIOVectorLength :: Addr -> CSize -> IO () 514 | pokeMessageHeaderIOVectorLength (Addr p) = #{poke struct msghdr, msg_iovlen} (Ptr p) 515 | 516 | pokeMessageHeaderControl :: Addr -> Addr -> IO () 517 | pokeMessageHeaderControl (Addr p) (Addr x) = #{poke struct msghdr, msg_control} (Ptr p) (Ptr x) 518 | 519 | pokeMessageHeaderControlLength :: Addr -> CSize -> IO () 520 | pokeMessageHeaderControlLength (Addr p) = #{poke struct msghdr, msg_controllen} (Ptr p) 521 | 522 | pokeMessageHeaderFlags :: Addr -> MessageFlags Receive -> IO () 523 | pokeMessageHeaderFlags (Addr p) (MessageFlags i) = #{poke struct msghdr, msg_flags} (Ptr p) i 524 | 525 | peekMessageHeaderNameLength :: Addr -> IO CInt 526 | peekMessageHeaderNameLength (Addr p) = #{peek struct msghdr, msg_namelen} (Ptr p) 527 | 528 | peekMessageHeaderIOVector :: Addr -> IO Addr 529 | peekMessageHeaderIOVector (Addr p) = do 530 | Ptr r <- #{peek struct msghdr, msg_iov} (Ptr p) 531 | pure (Addr r) 532 | 533 | peekMessageHeaderIOVectorLength :: Addr -> IO CSize 534 | peekMessageHeaderIOVectorLength (Addr p) = #{peek struct msghdr, msg_iovlen} (Ptr p) 535 | 536 | peekMessageHeaderControl :: Addr -> IO Addr 537 | peekMessageHeaderControl (Addr p) = do 538 | Ptr r <- #{peek struct msghdr, msg_control} (Ptr p) 539 | pure (Addr r) 540 | 541 | pokeIOVectorBase :: Addr -> Addr -> IO () 542 | pokeIOVectorBase (Addr p) (Addr x) = #{poke struct iovec, iov_base} (Ptr p) (Ptr x) 543 | 544 | pokeIOVectorLength :: Addr -> CSize -> IO () 545 | pokeIOVectorLength (Addr p) = #{poke struct iovec, iov_len} (Ptr p) 546 | 547 | peekMessageHeaderControlLength :: Addr -> IO CSize 548 | peekMessageHeaderControlLength (Addr p) = #{peek struct msghdr, msg_controllen} (Ptr p) 549 | 550 | peekMessageHeaderFlags :: Addr -> IO (MessageFlags Receive) 551 | peekMessageHeaderFlags (Addr p) = do 552 | i <- #{peek struct msghdr, msg_flags} (Ptr p) 553 | pure (MessageFlags i) 554 | 555 | unI :: Int -> Int## 556 | unI (I## i) = i 557 | 558 | -------------------------------------------------------------------------------- /src/Posix/Socket.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE DuplicateRecordFields #-} 5 | {-# LANGUAGE GADTSyntax #-} 6 | {-# LANGUAGE KindSignatures #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE MagicHash #-} 9 | {-# LANGUAGE NamedFieldPuns #-} 10 | {-# LANGUAGE PatternSynonyms #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE UnliftedFFITypes #-} 13 | 14 | {- | Types and functions related to the POSIX sockets API. 15 | Unusual characteristics: 16 | 17 | * Any time the standard calls for @socklen_t@, we use 18 | @CInt@ instead. Linus Torvalds 19 | that \"Any sane library must have @socklen_t@ be the same size as @int@. 20 | Anything else breaks any BSD socket layer stuff.\" 21 | * Send and receive each have several variants. They are distinguished by 22 | the safe\/unsafe FFI use and by the @Addr@\/@ByteArray@/@MutableByteArray@ 23 | buffer type. They all call @send@ or @recv@ exactly once. They do not 24 | repeatedly make syscalls like some of the functions in @network@. 25 | Users who want that behavior need to build on top of this package. 26 | * There are no requirements on the pinnedness of @ByteArray@ arguments 27 | passed to any of these functions. If wrappers of the safe FFI are 28 | passed unpinned @ByteArray@ arguments, they will copy the contents 29 | into pinned memory before invoking the foreign function. 30 | -} 31 | module Posix.Socket 32 | ( -- * Functions 33 | 34 | -- ** Socket 35 | uninterruptibleSocket 36 | , socket 37 | , withSocket 38 | 39 | -- ** Socket Pair 40 | , uninterruptibleSocketPair 41 | 42 | -- ** Address Resolution 43 | , getAddressInfo 44 | , uninterruptibleFreeAddressInfo 45 | 46 | -- ** Bind 47 | , uninterruptibleBind 48 | 49 | -- ** Connect 50 | , connect 51 | , uninterruptibleConnect 52 | , uninterruptibleConnectPtr 53 | 54 | -- ** Listen 55 | , uninterruptibleListen 56 | 57 | -- ** Accept 58 | , accept 59 | , uninterruptibleAccept 60 | , accept_ 61 | 62 | -- ** Get Socket Name 63 | , uninterruptibleGetSocketName 64 | 65 | -- ** Get Socket Option 66 | , uninterruptibleGetSocketOption 67 | 68 | -- ** Set Socket Option 69 | , uninterruptibleSetSocketOption 70 | , uninterruptibleSetSocketOptionByteArray 71 | , uninterruptibleSetSocketOptionInt 72 | 73 | -- ** Close 74 | , F.close 75 | , F.uninterruptibleClose 76 | , F.uninterruptibleErrorlessClose 77 | 78 | -- ** Shutdown 79 | , uninterruptibleShutdown 80 | 81 | -- ** Send 82 | , send 83 | , sendByteArray 84 | , sendMutableByteArray 85 | , uninterruptibleSend 86 | , uninterruptibleSendByteArray 87 | , uninterruptibleSendMutableByteArray 88 | 89 | -- ** Send To 90 | , uninterruptibleSendToByteArray 91 | , uninterruptibleSendToMutableByteArray 92 | , uninterruptibleSendToInternet 93 | , uninterruptibleSendToInternetByteArray 94 | , uninterruptibleSendToInternetMutableByteArray 95 | 96 | -- ** Write Vector 97 | 98 | -- ** Receive 99 | , receive 100 | , receiveByteArray 101 | , uninterruptibleReceive 102 | , uninterruptibleReceiveMutableByteArray 103 | 104 | -- ** Receive From 105 | , uninterruptibleReceiveFromMutableByteArray 106 | , uninterruptibleReceiveFromMutableByteArray_ 107 | , uninterruptibleReceiveFrom_ 108 | , uninterruptibleReceiveFromInternet 109 | , uninterruptibleReceiveFromInternetMutableByteArray 110 | 111 | -- ** Receive Message 112 | -- $receiveMessage 113 | , uninterruptibleSendMessageA 114 | , uninterruptibleSendMessageB 115 | 116 | -- ** Byte-Order Conversion 117 | -- $conversion 118 | , hostToNetworkLong 119 | , hostToNetworkShort 120 | , networkToHostLong 121 | , networkToHostShort 122 | 123 | -- * Types 124 | , Family (..) 125 | , Type (..) 126 | , Protocol (..) 127 | , OptionName (..) 128 | , OptionValue (..) 129 | , Level (..) 130 | , Message (..) 131 | , MessageFlags (..) 132 | , ShutdownType (..) 133 | , AddressInfo 134 | 135 | -- * Socket Address 136 | 137 | -- ** Types 138 | , SocketAddress (..) 139 | , PST.SocketAddressInternet (..) 140 | , PST.SocketAddressUnix (..) 141 | 142 | -- ** Encoding 143 | , PSP.encodeSocketAddressInternet 144 | , PSP.encodeSocketAddressUnix 145 | 146 | -- ** Decoding 147 | , PSP.decodeSocketAddressInternet 148 | , PSP.indexSocketAddressInternet 149 | 150 | -- ** Sizes 151 | , PSP.sizeofSocketAddressInternet 152 | 153 | -- * Data Construction 154 | 155 | -- ** Socket Domains 156 | , pattern PST.Unix 157 | , pattern PST.Unspecified 158 | , pattern PST.Internet 159 | , pattern PST.Internet6 160 | 161 | -- ** Socket Types 162 | , PST.stream 163 | , PST.datagram 164 | , PST.raw 165 | , PST.sequencedPacket 166 | 167 | -- ** Protocols 168 | , PST.defaultProtocol 169 | , PST.rawProtocol 170 | , PST.icmp 171 | , PST.tcp 172 | , PST.udp 173 | , PST.ip 174 | , PST.ipv6 175 | 176 | -- ** Receive Flags 177 | , PST.peek 178 | , PST.outOfBand 179 | , PST.waitAll 180 | 181 | -- ** Send Flags 182 | , PST.noSignal 183 | 184 | -- ** Shutdown Types 185 | , PST.read 186 | , PST.write 187 | , PST.readWrite 188 | 189 | -- ** Socket Levels 190 | , PST.levelSocket 191 | 192 | -- ** Option Names 193 | , PST.optionError 194 | , PST.bindToDevice 195 | , PST.broadcast 196 | , PST.reuseAddress 197 | 198 | -- ** Address Info 199 | 200 | -- *** Peek 201 | , PST.peekAddressInfoFlags 202 | 203 | -- *** Poke 204 | , PST.pokeAddressInfoFlags 205 | 206 | -- *** Metadata 207 | , PST.sizeofAddressInfo 208 | 209 | -- ** Message Header 210 | 211 | -- *** Peek 212 | , PST.peekMessageHeaderName 213 | , PST.peekMessageHeaderNameLength 214 | , PST.peekMessageHeaderIOVector 215 | , PST.peekMessageHeaderIOVectorLength 216 | , PST.peekMessageHeaderControl 217 | , PST.peekMessageHeaderControlLength 218 | , PST.peekMessageHeaderFlags 219 | , PST.peekControlMessageHeaderLevel 220 | , PST.peekControlMessageHeaderLength 221 | , PST.peekControlMessageHeaderType 222 | 223 | -- *** Poke 224 | , PST.pokeMessageHeaderName 225 | , PST.pokeMessageHeaderNameLength 226 | , PST.pokeMessageHeaderIOVector 227 | , PST.pokeMessageHeaderIOVectorLength 228 | , PST.pokeMessageHeaderControl 229 | , PST.pokeMessageHeaderControlLength 230 | , PST.pokeMessageHeaderFlags 231 | 232 | -- *** Metadata 233 | , PST.sizeofMessageHeader 234 | 235 | -- ** IO Vector 236 | 237 | -- *** Peek 238 | , PST.peekIOVectorBase 239 | , PST.peekIOVectorLength 240 | 241 | -- *** Poke 242 | , PST.pokeIOVectorBase 243 | , PST.pokeIOVectorLength 244 | 245 | -- *** Metadata 246 | , PST.sizeofIOVector 247 | ) where 248 | 249 | import Control.Exception (mask, onException) 250 | import Data.Primitive (ByteArray (..), MutableByteArray (..), MutablePrimArray (..)) 251 | import Data.Primitive.Addr (Addr (..)) 252 | import Data.Primitive.ByteArray.Offset (MutableByteArrayOffset (..)) 253 | import Data.Primitive.PrimArray.Offset (MutablePrimArrayOffset (..)) 254 | import Data.Void (Void) 255 | import Data.Word (Word16, Word32, Word8, byteSwap16, byteSwap32) 256 | import Foreign.C.Error (Errno (Errno), getErrno) 257 | import Foreign.C.String (CString) 258 | import Foreign.C.Types (CInt (..), CSize (..)) 259 | import Foreign.Ptr (nullPtr) 260 | import GHC.ByteOrder (ByteOrder (BigEndian, LittleEndian), targetByteOrder) 261 | import GHC.Exts (Addr#, ByteArray#, Int (I#), MutableByteArray#, Ptr (Ptr), RealWorld, shrinkMutableByteArray#) 262 | import Posix.Socket.Types 263 | ( AddressInfo 264 | , Family (..) 265 | , Level (..) 266 | , Message (..) 267 | , MessageFlags (..) 268 | , OptionName (..) 269 | , OptionValue (..) 270 | , Protocol (..) 271 | , ShutdownType (..) 272 | , SocketAddress (..) 273 | , SocketAddressInternet (..) 274 | , Type (..) 275 | ) 276 | import System.Posix.Types (CSsize (..), Fd (..)) 277 | 278 | import qualified Control.Monad.Primitive as PM 279 | import qualified Data.Primitive as PM 280 | import qualified GHC.Exts as Exts 281 | import qualified Posix.File as F 282 | import qualified Posix.Socket.Types as PST 283 | 284 | -- This module include operating-system specific code used 285 | -- to serialize some of various kind of socket address types. 286 | import qualified Posix.Socket.Platform as PSP 287 | 288 | -- getaddrinfo cannot use the unsafe ffi 289 | foreign import ccall safe "sys/socket.h getaddrinfo" 290 | c_safe_getaddrinfo :: 291 | CString -> 292 | CString -> 293 | Ptr AddressInfo -> 294 | MutableByteArray# RealWorld -> -- actually a `Ptr (Ptr AddressInfo))`. 295 | IO Errno 296 | 297 | -- | Free the @addrinfo@ at the pointer. 298 | foreign import ccall safe "sys/socket.h freeaddrinfo" 299 | uninterruptibleFreeAddressInfo :: Ptr AddressInfo -> IO () 300 | 301 | foreign import ccall unsafe "sys/socket.h socket" 302 | c_socket :: Family -> Type -> Protocol -> IO Fd 303 | 304 | foreign import ccall unsafe "sys/socket.h socketpair" 305 | c_socketpair :: Family -> Type -> Protocol -> MutableByteArray# RealWorld -> IO CInt 306 | 307 | foreign import ccall unsafe "sys/socket.h listen" 308 | c_listen :: Fd -> CInt -> IO CInt 309 | 310 | foreign import ccall unsafe "unistd.h shutdown" 311 | c_unsafe_shutdown :: Fd -> ShutdownType -> IO CInt 312 | 313 | -- Per the spec, the type signature of bind is: 314 | -- int bind(int socket, const struct sockaddr *address, socklen_t address_len); 315 | -- However, here we choose to represent the third argument as 316 | -- CInt rather than introducing a type corresponding to socklen_t. 317 | -- According to Linus Torvalds, "Any sane library must have socklen_t 318 | -- be the same size as int. Anything else breaks any BSD socket layer stuff." 319 | -- (https://yarchive.net/comp/linux/socklen_t.html). If a platform 320 | -- violates this assumption, this wrapper will be broken on that platform. 321 | foreign import ccall unsafe "sys/socket.h bind" 322 | c_bind :: Fd -> ByteArray# -> CInt -> IO CInt 323 | 324 | -- Per the spec, the type signature of accept is: 325 | -- int accept(int socket, struct sockaddr *restrict address, socklen_t *restrict address_len); 326 | -- The restrict keyword does not matter much for our purposes. See the 327 | -- note on c_bind for why we use CInt for socklen_t. Remember that the 328 | -- first bytearray argument is actually SocketAddress in the function that 329 | -- wraps this one. The second bytearray argument is a pointer to the size. 330 | foreign import ccall safe "sys/socket.h accept" 331 | c_safe_accept :: 332 | Fd -> 333 | MutableByteArray# RealWorld -> -- SocketAddress 334 | MutableByteArray# RealWorld -> -- Ptr CInt 335 | IO Fd 336 | foreign import ccall unsafe "sys/socket.h accept" 337 | c_unsafe_accept :: 338 | Fd -> 339 | MutableByteArray# RealWorld -> -- SocketAddress 340 | MutableByteArray# RealWorld -> -- Ptr CInt 341 | IO Fd 342 | 343 | -- This variant of accept is used when we do not care about the 344 | -- remote sockaddr. We pass null. 345 | foreign import ccall safe "sys/socket.h accept" 346 | c_safe_ptr_accept :: Fd -> Ptr Void -> Ptr CInt -> IO Fd 347 | 348 | foreign import ccall unsafe "sys/socket.h getsockname" 349 | c_unsafe_getsockname :: 350 | Fd -> 351 | MutableByteArray# RealWorld -> -- SocketAddress 352 | MutableByteArray# RealWorld -> -- Addr length (Ptr CInt) 353 | IO CInt 354 | 355 | foreign import ccall unsafe "sys/socket.h getsockopt" 356 | c_unsafe_getsockopt :: 357 | Fd -> 358 | Level -> 359 | OptionName -> 360 | MutableByteArray# RealWorld -> -- Option value 361 | MutableByteArray# RealWorld -> -- Option len (Ptr CInt) 362 | IO CInt 363 | 364 | foreign import ccall unsafe "sys/socket.h setsockopt_int" 365 | c_unsafe_setsockopt_int :: 366 | Fd -> 367 | Level -> 368 | OptionName -> 369 | CInt -> -- option_value 370 | IO CInt 371 | 372 | foreign import ccall unsafe "sys/socket.h setsockopt" 373 | c_unsafe_setsockopt :: 374 | Fd -> 375 | Level -> 376 | OptionName -> 377 | Ptr Void -> -- option_val 378 | CInt -> -- option_len 379 | IO CInt 380 | 381 | foreign import ccall unsafe "sys/socket.h setsockopt" 382 | c_unsafe_setsockopt_ba :: 383 | Fd -> 384 | Level -> 385 | OptionName -> 386 | ByteArray# -> -- option_val 387 | CInt -> -- option_len 388 | IO CInt 389 | 390 | -- Per the spec the type signature of connect is: 391 | -- int connect(int sockfd, const struct sockaddr *addr, socklen_t addrlen); 392 | -- The bytearray argument is actually SocketAddress. 393 | foreign import ccall safe "sys/socket.h connect" 394 | c_safe_connect :: Fd -> ByteArray# -> CInt -> IO CInt 395 | foreign import ccall safe "sys/socket.h connect" 396 | c_safe_mutablebytearray_connect :: Fd -> MutableByteArray# RealWorld -> CInt -> IO CInt 397 | foreign import ccall unsafe "sys/socket.h connect" 398 | c_unsafe_connect :: Fd -> ByteArray# -> CInt -> IO CInt 399 | foreign import ccall unsafe "sys/socket.h connect" 400 | c_unsafe_connect_addr :: Fd -> Addr# -> CInt -> IO CInt 401 | 402 | -- There are several options for wrapping send. Both safe and unsafe 403 | -- are useful. Additionally, in the unsafe category, we also 404 | -- have the option of writing to either an address or a byte array. 405 | -- Unsafe FFI calls guarantee that byte arrays will not be relocated 406 | -- while the FFI call is taking place. Safe FFI calls do not have 407 | -- this guarantee, so internally we must be careful when using these to only 408 | -- provide pinned byte arrays as arguments. 409 | foreign import ccall safe "sys/socket.h send" 410 | c_safe_addr_send :: Fd -> Addr# -> CSize -> MessageFlags 'Send -> IO CSsize 411 | foreign import ccall safe "sys/socket.h send_offset" 412 | c_safe_bytearray_send :: Fd -> ByteArray# -> Int -> CSize -> MessageFlags 'Send -> IO CSsize 413 | foreign import ccall safe "sys/socket.h send_offset" 414 | c_safe_mutablebytearray_send :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> MessageFlags 'Send -> IO CSsize 415 | foreign import ccall safe "sys/socket.h send" 416 | c_safe_mutablebytearray_no_offset_send :: Fd -> MutableByteArray# RealWorld -> CSize -> MessageFlags 'Send -> IO CSsize 417 | foreign import ccall unsafe "sys/socket.h send" 418 | c_unsafe_addr_send :: Fd -> Addr# -> CSize -> MessageFlags 'Send -> IO CSsize 419 | foreign import ccall unsafe "sys/socket.h send_offset" 420 | c_unsafe_bytearray_send :: Fd -> ByteArray# -> Int -> CSize -> MessageFlags 'Send -> IO CSsize 421 | foreign import ccall unsafe "sys/socket.h send_offset" 422 | c_unsafe_mutable_bytearray_send :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> MessageFlags 'Send -> IO CSsize 423 | 424 | -- The ByteArray# (second to last argument) is a SocketAddress. 425 | foreign import ccall unsafe "sys/socket.h sendto_offset" 426 | c_unsafe_bytearray_sendto :: Fd -> ByteArray# -> Int -> CSize -> MessageFlags 'Send -> ByteArray# -> CInt -> IO CSsize 427 | 428 | -- The ByteArray# (second to last argument) is a SocketAddress. 429 | foreign import ccall unsafe "sys/socket.h sendto_offset" 430 | c_unsafe_mutable_bytearray_sendto :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> MessageFlags 'Send -> ByteArray# -> CInt -> IO CSsize 431 | foreign import ccall unsafe "sys/socket.h sendto_inet_offset" 432 | c_unsafe_mutable_bytearray_sendto_inet :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> MessageFlags 'Send -> Word16 -> Word32 -> IO CSsize 433 | foreign import ccall unsafe "HaskellPosix.h sendto_inet_offset" 434 | c_unsafe_bytearray_sendto_inet :: Fd -> ByteArray# -> Int -> CSize -> MessageFlags 'Send -> Word16 -> Word32 -> IO CSsize 435 | foreign import ccall unsafe "HaskellPosix.h sendto_inet_addr" 436 | c_unsafe_addr_sendto_inet :: Fd -> Addr# -> CSize -> MessageFlags 'Send -> Word16 -> Word32 -> IO CSsize 437 | 438 | foreign import ccall unsafe "HaskellPosix.h sendmsg_a" 439 | c_unsafe_sendmsg_a :: Fd -> Addr# -> CSize -> MutableByteArray# RealWorld -> Int -> CSize -> MessageFlags 'Send -> IO CSsize 440 | 441 | foreign import ccall unsafe "HaskellPosix.h sendmsg_b" 442 | c_unsafe_sendmsg_b :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> Addr# -> CSize -> MessageFlags 'Send -> IO CSsize 443 | 444 | -- There are several ways to wrap recv. 445 | foreign import ccall safe "sys/socket.h recv" 446 | c_safe_addr_recv :: Fd -> Addr# -> CSize -> MessageFlags 'Receive -> IO CSsize 447 | foreign import ccall unsafe "sys/socket.h recv" 448 | c_unsafe_addr_recv :: Fd -> Addr# -> CSize -> MessageFlags 'Receive -> IO CSsize 449 | foreign import ccall unsafe "sys/socket.h recv_offset" 450 | c_unsafe_mutable_byte_array_recv :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> MessageFlags 'Receive -> IO CSsize 451 | 452 | -- The last two arguments are SocketAddress and Ptr CInt. 453 | foreign import ccall unsafe "sys/socket.h recvfrom_offset" 454 | c_unsafe_mutable_byte_array_recvfrom :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> MessageFlags 'Receive -> MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> IO CSsize 455 | foreign import ccall unsafe "sys/socket.h recvfrom_offset_peerless" 456 | c_unsafe_mutable_byte_array_peerless_recvfrom :: 457 | Fd -> 458 | MutableByteArray# RealWorld -> 459 | Int -> 460 | CSize -> 461 | MessageFlags 'Receive -> 462 | IO CSsize 463 | foreign import ccall unsafe "sys/socket.h recvfrom_addr_peerless" 464 | c_unsafe_addr_peerless_recvfrom :: 465 | Fd -> Addr# -> CSize -> MessageFlags 'Receive -> IO CSsize 466 | foreign import ccall unsafe "sys/socket.h recvfrom_offset_inet" 467 | c_unsafe_recvfrom_inet :: 468 | Fd -> 469 | MutableByteArray# RealWorld -> 470 | Int -> 471 | CSize -> 472 | MessageFlags 'Receive -> 473 | MutableByteArray# RealWorld -> 474 | Int -> 475 | IO CSsize 476 | foreign import ccall unsafe "sys/socket.h recvfrom_offset_inet_addr" 477 | c_unsafe_recvfrom_inet_addr :: 478 | Fd -> 479 | Addr# -> 480 | CSize -> 481 | MessageFlags 'Receive -> 482 | MutableByteArray# RealWorld -> 483 | Int -> 484 | IO CSsize 485 | 486 | {- | Create an endpoint for communication, returning a file 487 | descriptor that refers to that endpoint. The 488 | 489 | includes more details. No special preparation is required before calling 490 | this function. The author believes that it cannot block for a prolonged 491 | period of time. 492 | -} 493 | uninterruptibleSocket :: 494 | -- | Communications domain (e.g. 'internet', 'unix') 495 | Family -> 496 | -- | Socket type (e.g. 'datagram', 'stream') with flags 497 | Type -> 498 | -- | Protocol 499 | Protocol -> 500 | IO (Either Errno Fd) 501 | uninterruptibleSocket dom typ prot = c_socket dom typ prot >>= errorsFromFd 502 | 503 | -- | Alias for 'uninterruptibleSocket'. 504 | socket :: 505 | -- | Communications domain (e.g. 'internet', 'unix') 506 | Family -> 507 | -- | Socket type (e.g. 'datagram', 'stream') with flags 508 | Type -> 509 | -- | Protocol 510 | Protocol -> 511 | IO (Either Errno Fd) 512 | socket = uninterruptibleSocket 513 | 514 | {- | Helper function for the common case where 'socket' or 515 | 'uninterruptibleSocket' is paired with 'close'. This ensures that the 516 | socket is closed even in the case of an exception. Do not call 'close' in 517 | the callback since 'close' is called by this function after the callback 518 | completes (or after an exception is thrown). 519 | 520 | This is implementated with @mask@ (and restore) and @onException@ 521 | directly rather than with @bracket@. 522 | -} 523 | withSocket :: 524 | -- | Communications domain (e.g. 'internet', 'unix') 525 | Family -> 526 | -- | Socket type (e.g. 'datagram', 'stream') with flags 527 | Type -> 528 | -- | Protocol 529 | Protocol -> 530 | -- | Callback that uses the socket. Must not close the socket. 531 | -- The callback is not used when the @socket()@ call fails. 532 | (Fd -> IO a) -> 533 | IO (Either Errno a) 534 | {-# INLINE withSocket #-} 535 | withSocket !dom !typ !prot cb = 536 | mask $ \restore -> do 537 | r <- c_socket dom typ prot 538 | if r > (-1) 539 | then do 540 | a <- restore (cb r) `onException` F.close r 541 | _ <- F.close r 542 | pure (Right a) 543 | else fmap Left getErrno 544 | 545 | {- | Create an unbound pair of connected sockets in a specified domain, of 546 | a specified type, under the protocol optionally specified by the protocol 547 | argument. The 548 | includes more details. No special preparation is required before calling 549 | this function. The author believes that it cannot block for a prolonged 550 | period of time. 551 | -} 552 | uninterruptibleSocketPair :: 553 | -- | Communications domain (probably 'unix') 554 | Family -> 555 | -- | Socket type (e.g. 'datagram', 'stream') with flags 556 | Type -> 557 | -- | Protocol 558 | Protocol -> 559 | IO (Either Errno (Fd, Fd)) 560 | uninterruptibleSocketPair dom typ prot = do 561 | -- If this ever switches to the safe FFI, we will need to use 562 | -- a pinned array here instead. 563 | (sockets@(MutablePrimArray sockets#) :: MutablePrimArray RealWorld Fd) <- PM.newPrimArray 2 564 | r <- c_socketpair dom typ prot sockets# 565 | if r == 0 566 | then do 567 | fd1 <- PM.readPrimArray sockets 0 568 | fd2 <- PM.readPrimArray sockets 1 569 | pure (Right (fd1, fd2)) 570 | else fmap Left getErrno 571 | 572 | {- | Given node and service, which identify an Internet host and a service, 573 | @getaddrinfo()@ returns one or more @addrinfo@ structures. The type of this 574 | wrapper differs slightly from the type of its C counterpart. Remember to call 575 | 'uninterruptibleFreeAddressInfo' when finished with the result. 576 | -} 577 | getAddressInfo :: 578 | -- | Node, identifies an Internet host 579 | CString -> 580 | -- | Service 581 | CString -> 582 | -- | Hints 583 | Ptr AddressInfo -> 584 | IO (Either Errno (Ptr AddressInfo)) 585 | getAddressInfo !node !service !hints = do 586 | resBuf@(MutableByteArray resBuf#) <- PM.newPinnedByteArray (PM.sizeOf (undefined :: Ptr ())) 587 | c_safe_getaddrinfo node service hints resBuf# >>= \case 588 | Errno 0 -> do 589 | res <- PM.readByteArray resBuf 0 590 | pure (Right res) 591 | e -> pure (Left e) 592 | 593 | {- | Assign a local socket address address to a socket identified by 594 | descriptor socket that has no local socket address assigned. The 595 | 596 | includes more details. The 'SocketAddress' represents the @sockaddr@ pointer argument, together 597 | with its @socklen_t@ size, as a byte array. This allows @bind@ to 598 | be used with @sockaddr@ extensions on various platforms. No special 599 | preparation is required before calling this function. The author 600 | believes that it cannot block for a prolonged period of time. 601 | -} 602 | uninterruptibleBind :: 603 | -- | Socket 604 | Fd -> 605 | -- | Socket address, extensible tagged union 606 | SocketAddress -> 607 | IO (Either Errno ()) 608 | uninterruptibleBind fd (SocketAddress b@(ByteArray b#)) = 609 | c_bind fd b# (intToCInt (PM.sizeofByteArray b)) >>= errorsFromInt_ 610 | 611 | {- | Mark the socket as a passive socket, that is, as a socket that 612 | will be used to accept incoming connection requests using @accept@. 613 | The 614 | includes more details. No special preparation is required before 615 | calling this function. The author believes that it cannot block 616 | for a prolonged period of time. 617 | -} 618 | uninterruptibleListen :: 619 | -- | Socket 620 | Fd -> 621 | -- | Backlog 622 | CInt -> 623 | IO (Either Errno ()) 624 | uninterruptibleListen fd backlog = c_listen fd backlog >>= errorsFromInt_ 625 | 626 | {- | Connect the socket to the specified socket address. 627 | The 628 | includes more details. 629 | -} 630 | connect :: 631 | -- | Fd 632 | Fd -> 633 | -- | Socket address, extensible tagged union 634 | SocketAddress -> 635 | IO (Either Errno ()) 636 | connect fd (SocketAddress sockAddr@(ByteArray sockAddr#)) = 637 | case isByteArrayPinned sockAddr of 638 | True -> c_safe_connect fd sockAddr# (intToCInt (PM.sizeofByteArray sockAddr)) >>= errorsFromInt_ 639 | False -> do 640 | let len = PM.sizeofByteArray sockAddr 641 | x@(MutableByteArray x#) <- PM.newPinnedByteArray len 642 | PM.copyByteArray x 0 sockAddr 0 len 643 | c_safe_mutablebytearray_connect fd x# (intToCInt len) >>= errorsFromInt_ 644 | 645 | {- | Connect the socket to the specified socket address. 646 | The 647 | includes more details. The only sensible way to use this is to 648 | give a nonblocking socket as the argument. 649 | -} 650 | uninterruptibleConnect :: 651 | -- | Fd 652 | Fd -> 653 | -- | Socket address, extensible tagged union 654 | SocketAddress -> 655 | IO (Either Errno ()) 656 | uninterruptibleConnect fd (SocketAddress sockAddr@(ByteArray sockAddr#)) = 657 | c_unsafe_connect fd sockAddr# (intToCInt (PM.sizeofByteArray sockAddr)) >>= errorsFromInt_ 658 | 659 | uninterruptibleConnectPtr :: 660 | -- | Fd 661 | Fd -> 662 | -- | Socket address 663 | Ptr a -> 664 | -- | Size of socket address 665 | Int -> 666 | IO (Either Errno ()) 667 | uninterruptibleConnectPtr !fd (Ptr sockAddr#) !sz = 668 | c_unsafe_connect_addr fd sockAddr# (intToCInt sz) >>= errorsFromInt_ 669 | 670 | {- | Extract the first connection on the queue of pending connections. The 671 | 672 | includes more details. This function\'s type differs slightly from 673 | the specification: 674 | 675 | > int accept(int socket, struct sockaddr *restrict address, socklen_t *restrict address_len); 676 | 677 | Instead of requiring the caller to prepare buffers through which 678 | information is returned, this haskell binding to @accept@ prepares 679 | those buffers internally. This eschews C\'s characteristic buffer-passing 680 | in favor of the Haskell convention of allocating internally and returning. 681 | 682 | More specifically, this binding lacks an argument corresponding to the 683 | @sockaddr@ buffer from the specification. That mutable buffer is allocated 684 | internally, resized and frozen upon a success, and returned along with 685 | the file descriptor of the accepted socket. The size of this buffer is 686 | determined by the second argument (maximum socket address size). This 687 | size argument is also writen to the @address_len@ buffer, which is also 688 | allocated internally. The size returned through this pointer is used to 689 | resize the @sockaddr@ buffer, which is then frozen so that an immutable 690 | 'SocketAddress' is returned to the end user. 691 | 692 | For applications uninterested in the peer (described by @sockaddr@), 693 | POSIX @accept@ allows the null pointer to be passed as both @address@ and 694 | @address_len@. This behavior is provided by 'accept_'. 695 | -} 696 | accept :: 697 | -- | Listening socket 698 | Fd -> 699 | -- | Maximum socket address size 700 | CInt -> 701 | -- | Peer information and connected socket 702 | IO (Either Errno (CInt, SocketAddress, Fd)) 703 | accept !sock !maxSz = do 704 | sockAddrBuf@(MutableByteArray sockAddrBuf#) <- PM.newPinnedByteArray (cintToInt maxSz) 705 | lenBuf@(MutableByteArray lenBuf#) <- PM.newPinnedByteArray (PM.sizeOf (undefined :: CInt)) 706 | PM.writeByteArray lenBuf 0 maxSz 707 | r <- c_safe_accept sock sockAddrBuf# lenBuf# 708 | if r > (-1) 709 | then do 710 | (sz :: CInt) <- PM.readByteArray lenBuf 0 711 | -- Why copy when we could just shrink? We want to always return 712 | -- byte arrays that are not explicitly pinned. 713 | let minSz = min sz maxSz 714 | x <- PM.newByteArray (cintToInt minSz) 715 | PM.copyMutableByteArray x 0 sockAddrBuf 0 (cintToInt minSz) 716 | sockAddr <- PM.unsafeFreezeByteArray x 717 | pure (Right (sz, SocketAddress sockAddr, r)) 718 | else fmap Left getErrno 719 | 720 | {- | See 'accept'. This uses the unsafe FFI. Consequently, it does not 721 | not need to allocate pinned memory. It only makes sense to call this 722 | on a nonblocking socket. 723 | -} 724 | uninterruptibleAccept :: 725 | -- | Listening socket 726 | Fd -> 727 | -- | Maximum socket address size 728 | CInt -> 729 | -- | Peer information and connected socket 730 | IO (Either Errno (CInt, SocketAddress, Fd)) 731 | uninterruptibleAccept !sock !maxSz = do 732 | sockAddrBuf@(MutableByteArray sockAddrBuf#) <- PM.newByteArray (cintToInt maxSz) 733 | lenBuf@(MutableByteArray lenBuf#) <- PM.newByteArray (PM.sizeOf (undefined :: CInt)) 734 | PM.writeByteArray lenBuf 0 maxSz 735 | r <- c_unsafe_accept sock sockAddrBuf# lenBuf# 736 | if r > (-1) 737 | then do 738 | (sz :: CInt) <- PM.readByteArray lenBuf 0 739 | if sz < maxSz 740 | then shrinkMutableByteArray sockAddrBuf (cintToInt sz) 741 | else pure () 742 | sockAddr <- PM.unsafeFreezeByteArray sockAddrBuf 743 | pure (Right (sz, SocketAddress sockAddr, r)) 744 | else fmap Left getErrno 745 | 746 | {- | A variant of 'accept' that does not provide the user with a 747 | 'SocketAddress' detailing the peer. 748 | -} 749 | accept_ :: 750 | -- | Listening socket 751 | Fd -> 752 | -- | Connected socket 753 | IO (Either Errno Fd) 754 | accept_ sock = 755 | c_safe_ptr_accept sock nullPtr nullPtr >>= errorsFromFd 756 | 757 | {- | Retrieve the locally-bound name of the specified socket. The 758 | 759 | of @getsockname@ includes more details. 760 | -} 761 | uninterruptibleGetSocketName :: 762 | -- | Socket 763 | Fd -> 764 | -- | Maximum socket address size 765 | CInt -> 766 | IO (Either Errno (CInt, SocketAddress)) 767 | uninterruptibleGetSocketName sock maxSz = do 768 | sockAddrBuf@(MutableByteArray sockAddrBuf#) <- PM.newByteArray (cintToInt maxSz) 769 | lenBuf@(MutableByteArray lenBuf#) <- PM.newByteArray (PM.sizeOf (undefined :: CInt)) 770 | PM.writeByteArray lenBuf 0 maxSz 771 | r <- c_unsafe_getsockname sock sockAddrBuf# lenBuf# 772 | if r == 0 773 | then do 774 | (sz :: CInt) <- PM.readByteArray lenBuf 0 775 | if sz < maxSz 776 | then shrinkMutableByteArray sockAddrBuf (cintToInt sz) 777 | else pure () 778 | sockAddr <- PM.unsafeFreezeByteArray sockAddrBuf 779 | pure (Right (sz, SocketAddress sockAddr)) 780 | else fmap Left getErrno 781 | 782 | {- | Retrieve the value for the option specified by the 'Option' argument for 783 | the socket specified by the 'Fd' argument. The 784 | 785 | of @getsockopt@ includes more details. 786 | -} 787 | uninterruptibleGetSocketOption :: 788 | -- | Socket 789 | Fd -> 790 | -- | Socket level 791 | Level -> 792 | OptionName -> -- Option name 793 | 794 | -- | Maximum option value size 795 | CInt -> 796 | IO (Either Errno (CInt, OptionValue)) 797 | uninterruptibleGetSocketOption sock level optName maxSz = do 798 | valueBuf@(MutableByteArray valueBuf#) <- PM.newByteArray (cintToInt maxSz) 799 | lenBuf@(MutableByteArray lenBuf#) <- PM.newByteArray (PM.sizeOf (undefined :: CInt)) 800 | PM.writeByteArray lenBuf 0 maxSz 801 | r <- c_unsafe_getsockopt sock level optName valueBuf# lenBuf# 802 | if r == 0 803 | then do 804 | (sz :: CInt) <- PM.readByteArray lenBuf 0 805 | if sz < maxSz 806 | then shrinkMutableByteArray valueBuf (cintToInt sz) 807 | else pure () 808 | value <- PM.unsafeFreezeByteArray valueBuf 809 | pure (Right (sz, OptionValue value)) 810 | else fmap Left getErrno 811 | 812 | {- | Set the value for the option specified by the 'Option' argument for 813 | the socket specified by the 'Fd' argument. The 814 | 815 | of @getsockopt@ includes more details. This variant requires that the 816 | size of the @option_value@ 817 | be the same as the size of 'CInt'. That is, the @option_name@ must 818 | describe an option that is represented by a C integer. This is a 819 | common case, so we avoid allocations by reference-passing in C. 820 | -} 821 | uninterruptibleSetSocketOptionInt :: 822 | -- | Socket 823 | Fd -> 824 | -- | Socket level 825 | Level -> 826 | -- | Option name 827 | OptionName -> 828 | -- | Option value 829 | CInt -> 830 | IO (Either Errno ()) 831 | uninterruptibleSetSocketOptionInt sock level optName optValue = 832 | c_unsafe_setsockopt_int sock level optName optValue >>= errorsFromInt_ 833 | 834 | {- | Set the value for the option specified by the 'Option' argument for 835 | the socket specified by the 'Fd' argument. The 836 | 837 | of @getsockopt@ includes more details. 838 | -} 839 | uninterruptibleSetSocketOption :: 840 | -- | Socket 841 | Fd -> 842 | -- | Socket level 843 | Level -> 844 | -- | Option name 845 | OptionName -> 846 | -- | Option value 847 | Ptr Void -> 848 | -- | Option value length 849 | CInt -> 850 | IO (Either Errno ()) 851 | uninterruptibleSetSocketOption sock level optName optValue optLen = 852 | c_unsafe_setsockopt sock level optName optValue optLen >>= errorsFromInt_ 853 | 854 | {- | Variant of 'uninterruptibleSetSocketOption' that accepts the option 855 | as a byte array instead of a pointer into unmanaged memory. The argument 856 | does not need to be pinned. 857 | -} 858 | uninterruptibleSetSocketOptionByteArray :: 859 | -- | Socket 860 | Fd -> 861 | -- | Socket level 862 | Level -> 863 | -- | Option name 864 | OptionName -> 865 | -- | Option value 866 | ByteArray -> 867 | -- | Option value length 868 | CInt -> 869 | IO (Either Errno ()) 870 | uninterruptibleSetSocketOptionByteArray sock level optName (ByteArray optVal) optLen = 871 | c_unsafe_setsockopt_ba sock level optName optVal optLen >>= errorsFromInt_ 872 | 873 | {- | Send data from a byte array over a network socket. Users 874 | may specify an offset and a length to send fewer bytes than are 875 | actually present in the array. Since this uses the safe 876 | FFI, it allocates a pinned copy of the bytearry if it was not 877 | already pinned. 878 | -} 879 | sendByteArray :: 880 | -- | Socket 881 | Fd -> 882 | -- | Source byte array 883 | ByteArray -> 884 | -- | Offset into source array 885 | Int -> 886 | -- | Length in bytes 887 | CSize -> 888 | -- | Flags 889 | MessageFlags 'Send -> 890 | -- | Number of bytes pushed to send buffer 891 | IO (Either Errno CSize) 892 | sendByteArray fd b@(ByteArray b#) off len flags = 893 | if isByteArrayPinned b 894 | then errorsFromSize =<< c_safe_bytearray_send fd b# off len flags 895 | else do 896 | x@(MutableByteArray x#) <- PM.newPinnedByteArray (csizeToInt len) 897 | PM.copyByteArray x off b 0 (csizeToInt len) 898 | errorsFromSize =<< c_safe_mutablebytearray_no_offset_send fd x# len flags 899 | 900 | {- | Copy and pin a byte array if, it's not already pinned. 901 | pinByteArray :: ByteArray -> IO (Maybe ByteArray) 902 | {\-# INLINE pinByteArray #-\} 903 | pinByteArray byteArray = 904 | if isByteArrayPinned byteArray 905 | then 906 | pure Nothing 907 | else do 908 | pinnedByteArray <- PM.newPinnedByteArray len 909 | PM.copyByteArray pinnedByteArray 0 byteArray 0 len 910 | r <- PM.unsafeFreezeByteArray pinnedByteArray 911 | pure (Just r) 912 | where 913 | len = PM.sizeofByteArray byteArray 914 | -} 915 | 916 | {- | Send two payloads (one from unmanaged memory and one from 917 | managed memory) over a network socket. 918 | -} 919 | uninterruptibleSendMessageA :: 920 | -- | Socket 921 | Fd -> 922 | -- | Source address (payload A) 923 | Addr -> 924 | -- | Length in bytes (payload A) 925 | CSize -> 926 | -- | Source and offset (payload B) 927 | MutableByteArrayOffset RealWorld -> 928 | -- | Length in bytes (payload B) 929 | CSize -> 930 | -- | Flags 931 | MessageFlags 'Send -> 932 | -- | Number of bytes pushed to send buffer 933 | IO (Either Errno CSize) 934 | uninterruptibleSendMessageA 935 | fd 936 | (Addr addr) 937 | lenA 938 | (MutableByteArrayOffset {array, offset}) 939 | lenB 940 | flags = 941 | c_unsafe_sendmsg_a fd addr lenA (unMba array) offset lenB flags 942 | >>= errorsFromSize 943 | 944 | {- | Send two payloads (one from managed memory and one from 945 | unmanaged memory) over a network socket. 946 | -} 947 | uninterruptibleSendMessageB :: 948 | -- | Socket 949 | Fd -> 950 | -- | Source and offset (payload B) 951 | MutableByteArrayOffset RealWorld -> 952 | -- | Length in bytes (payload B) 953 | CSize -> 954 | -- | Source address (payload A) 955 | Addr -> 956 | -- | Length in bytes (payload A) 957 | CSize -> 958 | -- | Flags 959 | MessageFlags 'Send -> 960 | -- | Number of bytes pushed to send buffer 961 | IO (Either Errno CSize) 962 | uninterruptibleSendMessageB 963 | fd 964 | (MutableByteArrayOffset {array, offset}) 965 | lenB 966 | (Addr addr) 967 | lenA 968 | flags = 969 | c_unsafe_sendmsg_b fd (unMba array) offset lenB addr lenA flags 970 | >>= errorsFromSize 971 | 972 | {- | Send data from a mutable byte array over a network socket. Users 973 | may specify an offset and a length to send fewer bytes than are 974 | actually present in the array. Since this uses the safe 975 | FFI, it allocates a pinned copy of the bytearry if it was not 976 | already pinned. 977 | -} 978 | sendMutableByteArray :: 979 | -- | Socket 980 | Fd -> 981 | -- | Source byte array 982 | MutableByteArray RealWorld -> 983 | -- | Offset into source array 984 | Int -> 985 | -- | Length in bytes 986 | CSize -> 987 | -- | Flags 988 | MessageFlags 'Send -> 989 | -- | Number of bytes pushed to send buffer 990 | IO (Either Errno CSize) 991 | sendMutableByteArray fd b@(MutableByteArray b#) off len flags = 992 | if isMutableByteArrayPinned b 993 | then errorsFromSize =<< c_safe_mutablebytearray_send fd b# off len flags 994 | else do 995 | x@(MutableByteArray x#) <- PM.newPinnedByteArray (csizeToInt len) 996 | PM.copyMutableByteArray x off b 0 (csizeToInt len) 997 | errorsFromSize =<< c_safe_mutablebytearray_no_offset_send fd x# len flags 998 | 999 | {- | Send data from an address over a network socket. This is not guaranteed 1000 | to send the entire length. This uses the safe FFI since 1001 | it may block indefinitely. 1002 | -} 1003 | send :: 1004 | -- | Connected socket 1005 | Fd -> 1006 | -- | Source address 1007 | Addr -> 1008 | -- | Length in bytes 1009 | CSize -> 1010 | -- | Flags 1011 | MessageFlags 'Send -> 1012 | -- | Number of bytes pushed to send buffer 1013 | IO (Either Errno CSize) 1014 | send fd (Addr addr) len flags = 1015 | c_safe_addr_send fd addr len flags >>= errorsFromSize 1016 | 1017 | {- | Send data from an address over a network socket. This uses the unsafe FFI. 1018 | Users of this function should be sure to set flags that prohibit this 1019 | from blocking. On Linux this is accomplished with @O_NONBLOCK@. It is 1020 | often desirable to call 'threadWaitWrite' on a nonblocking socket before 1021 | calling @unsafeSend@ on it. 1022 | -} 1023 | uninterruptibleSend :: 1024 | -- | Socket 1025 | Fd -> 1026 | -- | Source address 1027 | Addr -> 1028 | -- | Length in bytes 1029 | CSize -> 1030 | -- | Flags 1031 | MessageFlags 'Send -> 1032 | -- | Number of bytes pushed to send buffer 1033 | IO (Either Errno CSize) 1034 | uninterruptibleSend fd (Addr addr) len flags = 1035 | c_unsafe_addr_send fd addr len flags >>= errorsFromSize 1036 | 1037 | {- | Send data from a byte array over a network socket. This uses the unsafe FFI; 1038 | considerations pertaining to 'sendUnsafe' apply to this function as well. Users 1039 | may specify a length to send fewer bytes than are actually present in the 1040 | array. 1041 | -} 1042 | uninterruptibleSendByteArray :: 1043 | -- | Socket 1044 | Fd -> 1045 | -- | Source byte array 1046 | ByteArray -> 1047 | -- | Offset into source array 1048 | Int -> 1049 | -- | Length in bytes 1050 | CSize -> 1051 | -- | Flags 1052 | MessageFlags 'Send -> 1053 | -- | Number of bytes pushed to send buffer 1054 | IO (Either Errno CSize) 1055 | uninterruptibleSendByteArray fd (ByteArray b) off len flags = 1056 | c_unsafe_bytearray_send fd b off len flags >>= errorsFromSize 1057 | 1058 | {- | Send data from a mutable byte array over a network socket. This uses the unsafe FFI; 1059 | considerations pertaining to 'sendUnsafe' apply to this function as well. Users 1060 | specify an offset and a length to send fewer bytes than are actually present in the 1061 | array. 1062 | -} 1063 | uninterruptibleSendMutableByteArray :: 1064 | -- | Socket 1065 | Fd -> 1066 | -- | Source mutable byte array 1067 | MutableByteArray RealWorld -> 1068 | -- | Offset into source array 1069 | Int -> 1070 | -- | Length in bytes 1071 | CSize -> 1072 | -- | Flags 1073 | MessageFlags 'Send -> 1074 | -- | Number of bytes pushed to send buffer 1075 | IO (Either Errno CSize) 1076 | uninterruptibleSendMutableByteArray fd (MutableByteArray b) off len flags = 1077 | c_unsafe_mutable_bytearray_send fd b off len flags >>= errorsFromSize 1078 | 1079 | {- | Send data from a byte array over an unconnected network socket. 1080 | This uses the unsafe FFI; considerations pertaining to 'sendToUnsafe' 1081 | apply to this function as well. The offset and length arguments 1082 | cause a slice of the byte array to be sent rather than the entire 1083 | byte array. 1084 | -} 1085 | uninterruptibleSendToByteArray :: 1086 | -- | Socket 1087 | Fd -> 1088 | -- | Source byte array 1089 | ByteArray -> 1090 | -- | Offset into source array 1091 | Int -> 1092 | -- | Length in bytes 1093 | CSize -> 1094 | -- | Flags 1095 | MessageFlags 'Send -> 1096 | -- | Socket Address 1097 | SocketAddress -> 1098 | -- | Number of bytes pushed to send buffer 1099 | IO (Either Errno CSize) 1100 | uninterruptibleSendToByteArray fd (ByteArray b) off len flags (SocketAddress a@(ByteArray a#)) = 1101 | c_unsafe_bytearray_sendto fd b off len flags a# (intToCInt (PM.sizeofByteArray a)) >>= errorsFromSize 1102 | 1103 | {- | Variant of 'uninterruptibleSendToByteArray' that requires 1104 | that @sockaddr_in@ be used as the socket address. This is used to 1105 | avoid allocating a buffer for the socket address when the caller 1106 | knows in advance that they are sending to an IPv4 address. 1107 | -} 1108 | uninterruptibleSendToInternetByteArray :: 1109 | -- | Socket 1110 | Fd -> 1111 | -- | Source byte array 1112 | ByteArray -> 1113 | -- | Offset into source array 1114 | Int -> 1115 | -- | Length in bytes 1116 | CSize -> 1117 | -- | Flags 1118 | MessageFlags 'Send -> 1119 | -- | Socket Address 1120 | SocketAddressInternet -> 1121 | -- | Number of bytes pushed to send buffer 1122 | IO (Either Errno CSize) 1123 | uninterruptibleSendToInternetByteArray fd (ByteArray b) off len flags (SocketAddressInternet {port, address}) = 1124 | c_unsafe_bytearray_sendto_inet fd b off len flags port address >>= errorsFromSize 1125 | 1126 | {- | Variant of 'uninterruptibleSendToByteArray' that requires 1127 | that @sockaddr_in@ be used as the socket address. This is used to 1128 | avoid allocating a buffer for the socket address when the caller 1129 | knows in advance that they are sending to an IPv4 address. 1130 | -} 1131 | uninterruptibleSendToInternet :: 1132 | -- | Socket 1133 | Fd -> 1134 | -- | Source byte array 1135 | Addr -> 1136 | -- | Length in bytes 1137 | CSize -> 1138 | -- | Flags 1139 | MessageFlags 'Send -> 1140 | -- | Socket Address 1141 | SocketAddressInternet -> 1142 | -- | Number of bytes pushed to send buffer 1143 | IO (Either Errno CSize) 1144 | uninterruptibleSendToInternet fd (Addr b) len flags (SocketAddressInternet {port, address}) = 1145 | c_unsafe_addr_sendto_inet fd b len flags port address >>= errorsFromSize 1146 | 1147 | {- | Send data from a mutable byte array over an unconnected network socket. 1148 | This uses the unsafe FFI; concerns pertaining to 'uninterruptibleSend' 1149 | apply to this function as well. The offset and length arguments 1150 | cause a slice of the mutable byte array to be sent rather than the entire 1151 | byte array. 1152 | -} 1153 | uninterruptibleSendToMutableByteArray :: 1154 | -- | Socket 1155 | Fd -> 1156 | -- | Source byte array 1157 | MutableByteArray RealWorld -> 1158 | -- | Offset into source array 1159 | Int -> 1160 | -- | Length in bytes 1161 | CSize -> 1162 | -- | Flags 1163 | MessageFlags 'Send -> 1164 | -- | Socket Address 1165 | SocketAddress -> 1166 | -- | Number of bytes pushed to send buffer 1167 | IO (Either Errno CSize) 1168 | uninterruptibleSendToMutableByteArray fd (MutableByteArray b) off len flags (SocketAddress a@(ByteArray a#)) = 1169 | c_unsafe_mutable_bytearray_sendto fd b off len flags a# (intToCInt (PM.sizeofByteArray a)) >>= errorsFromSize 1170 | 1171 | {- | Variant of 'uninterruptibleSendToMutableByteArray' that requires 1172 | that @sockaddr_in@ be used as the socket address. This is used to 1173 | avoid allocating a buffer for the socket address when the caller 1174 | knows in advance that they are sending to an IPv4 address. 1175 | -} 1176 | uninterruptibleSendToInternetMutableByteArray :: 1177 | -- | Socket 1178 | Fd -> 1179 | -- | Source byte array 1180 | MutableByteArray RealWorld -> 1181 | -- | Offset into source array 1182 | Int -> 1183 | -- | Length in bytes 1184 | CSize -> 1185 | -- | Flags 1186 | MessageFlags 'Send -> 1187 | -- | Socket Address 1188 | SocketAddressInternet -> 1189 | -- | Number of bytes pushed to send buffer 1190 | IO (Either Errno CSize) 1191 | uninterruptibleSendToInternetMutableByteArray fd (MutableByteArray b) off len flags (SocketAddressInternet {port, address}) = 1192 | c_unsafe_mutable_bytearray_sendto_inet fd b off len flags port address >>= errorsFromSize 1193 | 1194 | {- | Receive data into an address from a network socket. This wraps @recv@ using 1195 | the safe FFI. When the returned size is zero, there are no 1196 | additional bytes to receive and the peer has performed an orderly shutdown. 1197 | -} 1198 | receive :: 1199 | -- | Socket 1200 | Fd -> 1201 | -- | Source address 1202 | Addr -> 1203 | -- | Length in bytes 1204 | CSize -> 1205 | -- | Flags 1206 | MessageFlags 'Receive -> 1207 | IO (Either Errno CSize) 1208 | receive fd (Addr addr) len flags = 1209 | c_safe_addr_recv fd addr len flags >>= errorsFromSize 1210 | 1211 | {- | Receive data into a byte array from a network socket. This wraps @recv@ using 1212 | the safe FFI. When the returned size is zero, there are no 1213 | additional bytes to receive and the peer has performed an orderly shutdown. 1214 | -} 1215 | receiveByteArray :: 1216 | -- | Socket 1217 | Fd -> 1218 | -- | Length in bytes 1219 | CSize -> 1220 | -- | Flags 1221 | MessageFlags 'Receive -> 1222 | IO (Either Errno ByteArray) 1223 | receiveByteArray !fd !len !flags = do 1224 | m <- PM.newPinnedByteArray (csizeToInt len) 1225 | let !(Addr addr) = ptrToAddr (PM.mutableByteArrayContents m) 1226 | r <- c_safe_addr_recv fd addr len flags 1227 | if r /= (-1) 1228 | then do 1229 | -- Why copy when we could just shrink? We want to always return 1230 | -- byte arrays that are not explicitly pinned. 1231 | let sz = cssizeToInt r 1232 | x <- PM.newByteArray sz 1233 | PM.copyMutableByteArray x 0 m 0 sz 1234 | a <- PM.unsafeFreezeByteArray x 1235 | pure (Right a) 1236 | else fmap Left getErrno 1237 | 1238 | {- | Receive data into an address from a network socket. This wraps @recv@ 1239 | using the unsafe FFI. Users of this function should be sure to set flags 1240 | that prohibit this from blocking. On Linux this is accomplished by setting 1241 | the @MSG_DONTWAIT@ flag and handling the resulting @EAGAIN@ or 1242 | @EWOULDBLOCK@. When the returned size is zero, there are no additional 1243 | bytes to receive and the peer has performed an orderly shutdown. 1244 | -} 1245 | uninterruptibleReceive :: 1246 | -- | Socket 1247 | Fd -> 1248 | -- | Source address 1249 | Addr -> 1250 | -- | Length in bytes 1251 | CSize -> 1252 | -- | Flags 1253 | MessageFlags 'Receive -> 1254 | IO (Either Errno CSize) 1255 | {-# INLINE uninterruptibleReceive #-} 1256 | uninterruptibleReceive !fd (Addr !addr) !len !flags = 1257 | c_unsafe_addr_recv fd addr len flags >>= errorsFromSize 1258 | 1259 | {- | Receive data into an address from a network socket. This uses the unsafe 1260 | FFI; considerations pertaining to 'receiveUnsafe' apply to this function 1261 | as well. Users may specify a length to receive fewer bytes than are 1262 | actually present in the mutable byte array. 1263 | -} 1264 | uninterruptibleReceiveMutableByteArray :: 1265 | -- | Socket 1266 | Fd -> 1267 | -- | Destination byte array 1268 | MutableByteArray RealWorld -> 1269 | -- | Destination offset 1270 | Int -> 1271 | -- | Maximum bytes to receive 1272 | CSize -> 1273 | -- | Flags 1274 | MessageFlags 'Receive -> 1275 | -- | Bytes received into array 1276 | IO (Either Errno CSize) 1277 | {-# INLINE uninterruptibleReceiveMutableByteArray #-} 1278 | uninterruptibleReceiveMutableByteArray !fd (MutableByteArray !b) !off !len !flags = 1279 | c_unsafe_mutable_byte_array_recv fd b off len flags >>= errorsFromSize 1280 | 1281 | {- | Receive data into an address from an unconnected network socket. This 1282 | uses the unsafe FFI. Users may specify an offset into the destination 1283 | byte array. This function does not resize the buffer. 1284 | -} 1285 | uninterruptibleReceiveFromMutableByteArray :: 1286 | -- | Socket 1287 | Fd -> 1288 | -- | Destination byte array 1289 | MutableByteArray RealWorld -> 1290 | -- | Destination offset 1291 | Int -> 1292 | -- | Maximum bytes to receive 1293 | CSize -> 1294 | -- | Flags 1295 | MessageFlags 'Receive -> 1296 | -- | Maximum socket address size 1297 | CInt -> 1298 | -- | Remote host, bytes received into array, bytes needed for @addrlen@. 1299 | IO (Either Errno (CInt, SocketAddress, CSize)) 1300 | {-# INLINE uninterruptibleReceiveFromMutableByteArray #-} 1301 | -- GHC does not inline this unless we give it the pragma. We really 1302 | -- want this to inline since inlining typically avoids the Left/Right 1303 | -- data constructor allocation. 1304 | uninterruptibleReceiveFromMutableByteArray !fd (MutableByteArray !b) !off !len !flags !maxSz = do 1305 | -- TODO: We currently allocate one buffer for the size and 1306 | -- one for the peer. We could improve this by allocating 1307 | -- a single buffer instead. We would need to add some 1308 | -- cleverness in the cbits directory. 1309 | sockAddrBuf@(MutableByteArray sockAddrBuf#) <- PM.newByteArray (cintToInt maxSz) 1310 | lenBuf@(MutableByteArray lenBuf#) <- PM.newByteArray (PM.sizeOf (undefined :: CInt)) 1311 | PM.writeByteArray lenBuf 0 maxSz 1312 | r <- c_unsafe_mutable_byte_array_recvfrom fd b off len flags sockAddrBuf# lenBuf# 1313 | if r > (-1) 1314 | then do 1315 | (sz :: CInt) <- PM.readByteArray lenBuf 0 1316 | if sz < maxSz 1317 | then shrinkMutableByteArray sockAddrBuf (cintToInt sz) 1318 | else pure () 1319 | sockAddr <- PM.unsafeFreezeByteArray sockAddrBuf 1320 | pure (Right (sz, SocketAddress sockAddr, cssizeToCSize r)) 1321 | else fmap Left getErrno 1322 | 1323 | uninterruptibleReceiveFromInternet :: 1324 | -- | Socket 1325 | Fd -> 1326 | -- | Destination byte array 1327 | Addr -> 1328 | -- | Maximum bytes to receive 1329 | CSize -> 1330 | -- | Flags 1331 | MessageFlags 'Receive -> 1332 | -- | Address 1333 | MutablePrimArrayOffset RealWorld SocketAddressInternet -> 1334 | -- | Number of bytes received into array 1335 | IO (Either Errno CSize) 1336 | {-# INLINE uninterruptibleReceiveFromInternet #-} 1337 | uninterruptibleReceiveFromInternet 1338 | !fd 1339 | (Addr b) 1340 | !len 1341 | !flags 1342 | (MutablePrimArrayOffset (MutablePrimArray sockAddrBuf) addrOff) = 1343 | c_unsafe_recvfrom_inet_addr fd b len flags sockAddrBuf addrOff 1344 | >>= errorsFromSize 1345 | 1346 | uninterruptibleReceiveFromInternetMutableByteArray :: 1347 | -- | Socket 1348 | Fd -> 1349 | -- | Destination byte array 1350 | MutableByteArrayOffset RealWorld -> 1351 | -- | Maximum bytes to receive 1352 | CSize -> 1353 | -- | Flags 1354 | MessageFlags 'Receive -> 1355 | -- | Address 1356 | MutablePrimArrayOffset RealWorld SocketAddressInternet -> 1357 | -- | Number of bytes received into array 1358 | IO (Either Errno CSize) 1359 | {-# INLINE uninterruptibleReceiveFromInternetMutableByteArray #-} 1360 | uninterruptibleReceiveFromInternetMutableByteArray 1361 | !fd 1362 | (MutableByteArrayOffset (MutableByteArray b) off) 1363 | !len 1364 | !flags 1365 | (MutablePrimArrayOffset (MutablePrimArray sockAddrBuf) addrOff) = 1366 | c_unsafe_recvfrom_inet fd b off len flags sockAddrBuf addrOff 1367 | >>= errorsFromSize 1368 | 1369 | {- | Receive data into an address from a network socket. This uses the unsafe 1370 | FFI. This does not return the socket address of the remote host that 1371 | sent the packet received. 1372 | -} 1373 | uninterruptibleReceiveFromMutableByteArray_ :: 1374 | -- | Socket 1375 | Fd -> 1376 | -- | Destination byte array 1377 | MutableByteArray RealWorld -> 1378 | -- | Destination offset 1379 | Int -> 1380 | -- | Maximum bytes to receive 1381 | CSize -> 1382 | -- | Flags 1383 | MessageFlags 'Receive -> 1384 | -- | Number of bytes received into array 1385 | IO (Either Errno CSize) 1386 | {-# INLINE uninterruptibleReceiveFromMutableByteArray_ #-} 1387 | uninterruptibleReceiveFromMutableByteArray_ !fd (MutableByteArray !b) !off !len !flags = 1388 | c_unsafe_mutable_byte_array_peerless_recvfrom fd b off len flags 1389 | >>= errorsFromSize 1390 | 1391 | {- | Receive data into an address from a network socket. This uses the unsafe 1392 | FFI. This does not return the socket address of the remote host that 1393 | sent the packet received. 1394 | -} 1395 | uninterruptibleReceiveFrom_ :: 1396 | -- | Socket 1397 | Fd -> 1398 | -- | Destination byte array 1399 | Addr -> 1400 | -- | Maximum bytes to receive 1401 | CSize -> 1402 | -- | Flags 1403 | MessageFlags 'Receive -> 1404 | -- | Number of bytes received into array 1405 | IO (Either Errno CSize) 1406 | {-# INLINE uninterruptibleReceiveFrom_ #-} 1407 | uninterruptibleReceiveFrom_ !fd (Addr !b) !len !flags = 1408 | c_unsafe_addr_peerless_recvfrom fd b len flags 1409 | >>= errorsFromSize 1410 | 1411 | ptrToAddr :: Ptr Word8 -> Addr 1412 | ptrToAddr (Exts.Ptr a) = Addr a 1413 | 1414 | -- | Shutdown a socket. This uses the unsafe FFI. 1415 | uninterruptibleShutdown :: 1416 | Fd -> 1417 | ShutdownType -> 1418 | IO (Either Errno ()) 1419 | uninterruptibleShutdown fd typ = 1420 | c_unsafe_shutdown fd typ >>= errorsFromInt_ 1421 | 1422 | errorsFromSize :: CSsize -> IO (Either Errno CSize) 1423 | errorsFromSize r = 1424 | if r > (-1) 1425 | then pure (Right (cssizeToCSize r)) 1426 | else fmap Left getErrno 1427 | 1428 | errorsFromFd :: Fd -> IO (Either Errno Fd) 1429 | errorsFromFd r = 1430 | if r > (-1) 1431 | then pure (Right r) 1432 | else fmap Left getErrno 1433 | 1434 | -- Sometimes, functions that return an int use zero to indicate 1435 | -- success and negative one to indicate failure without including 1436 | -- additional information in the value. 1437 | errorsFromInt_ :: CInt -> IO (Either Errno ()) 1438 | errorsFromInt_ r = 1439 | if r == 0 1440 | then pure (Right ()) 1441 | else fmap Left getErrno 1442 | 1443 | intToCInt :: Int -> CInt 1444 | intToCInt = fromIntegral 1445 | 1446 | cintToInt :: CInt -> Int 1447 | cintToInt = fromIntegral 1448 | 1449 | csizeToInt :: CSize -> Int 1450 | csizeToInt = fromIntegral 1451 | 1452 | cssizeToInt :: CSsize -> Int 1453 | cssizeToInt = fromIntegral 1454 | 1455 | -- only call this when it is known that the argument is non-negative 1456 | cssizeToCSize :: CSsize -> CSize 1457 | cssizeToCSize = fromIntegral 1458 | 1459 | shrinkMutableByteArray :: MutableByteArray RealWorld -> Int -> IO () 1460 | shrinkMutableByteArray (MutableByteArray arr) (I# sz) = 1461 | PM.primitive_ (shrinkMutableByteArray# arr sz) 1462 | 1463 | -- | Convert a 16-bit word from host to network byte order (e.g. @htons@). 1464 | hostToNetworkShort :: Word16 -> Word16 1465 | hostToNetworkShort = case targetByteOrder of 1466 | BigEndian -> id 1467 | LittleEndian -> byteSwap16 1468 | 1469 | -- | Convert a 16-bit word from network to host byte order (e.g. @ntohs@). 1470 | networkToHostShort :: Word16 -> Word16 1471 | networkToHostShort = case targetByteOrder of 1472 | BigEndian -> id 1473 | LittleEndian -> byteSwap16 1474 | 1475 | -- | Convert a 32-bit word from host to network byte order (e.g. @htonl@). 1476 | hostToNetworkLong :: Word32 -> Word32 1477 | hostToNetworkLong = case targetByteOrder of 1478 | BigEndian -> id 1479 | LittleEndian -> byteSwap32 1480 | 1481 | -- | Convert a 32-bit word from network to host byte order (e.g. @ntohl@). 1482 | networkToHostLong :: Word32 -> Word32 1483 | networkToHostLong = case targetByteOrder of 1484 | BigEndian -> id 1485 | LittleEndian -> byteSwap32 1486 | 1487 | {- $conversion 1488 | These functions are used to convert IPv4 addresses and ports between network 1489 | byte order and host byte order. They are essential when working with 1490 | 'SocketAddressInternet'. To avoid getting in the way of GHC compile-time 1491 | optimizations, these functions are not actually implemented with FFI 1492 | calls to @htonl@ and friends. Rather, they are reimplemented in haskell. 1493 | -} 1494 | 1495 | {- $receiveMessage 1496 | The function @recvMsg@ presents us with a challenge. Since it uses a 1497 | data structure with many nested pointers, we have to use pinned byte 1498 | arrays for everything. There is also the difficulty of marshalling 1499 | haskell's unlifted array (array of arrays) type into what C's 1500 | array of @iovec@. There's the question of the array of @cmsghdr@s. 1501 | On top of all of this, we have to answer the question of whether 1502 | we want to accept mutable buffer or whether we want to do the 1503 | allocations internally (both for the buffers and for the ancilliary 1504 | data structurs needed to massage the data into what C expects). 1505 | 1506 | What we do to handle this in offer several variants of @recvmsg@ 1507 | ending in @A@, @B@, etc. 1508 | -} 1509 | 1510 | isByteArrayPinned :: ByteArray -> Bool 1511 | {-# INLINE isByteArrayPinned #-} 1512 | isByteArrayPinned (ByteArray arr#) = 1513 | Exts.isTrue# (Exts.isByteArrayPinned# arr#) 1514 | 1515 | isMutableByteArrayPinned :: MutableByteArray s -> Bool 1516 | {-# INLINE isMutableByteArrayPinned #-} 1517 | isMutableByteArrayPinned (MutableByteArray marr#) = 1518 | Exts.isTrue# (Exts.isMutableByteArrayPinned# marr#) 1519 | 1520 | unMba :: MutableByteArray s -> MutableByteArray# s 1521 | {-# INLINE unMba #-} 1522 | unMba (MutableByteArray x) = x 1523 | --------------------------------------------------------------------------------