diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,25 @@ +# Revision history for network-light + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. + +## 0.1.0.1 -- YYYY-mm-dd + +* Just cleanups + +## 0.1.0.2 -- 2025-09-30 + +* Add README with example +* Small changes to make it compile with both mhs and ghc + +## 0.1.0.4 -- 2026-04-22 + +* Previous version only worked non-blockingly with GHC, not MHS (as MHS did not implement anything to combat non-blocking IO). I have added simple support for non-blocking IO in MHS, whereas a green thread may continue running while another is blocking on a call in this file. +* Refactoring work. +* Small changes to README + +## 0.1.0.5 -- 2026-07-16 + +* Made it work with GHC again, and added some tests. +* Worked on the Haddock documentation, before eventually putting it on Hackage. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +Copyright 2025 Robert Krook, Lennart Augustsson. + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. diff --git a/network-light.cabal b/network-light.cabal new file mode 100644 --- /dev/null +++ b/network-light.cabal @@ -0,0 +1,49 @@ +cabal-version: 3.0 +name: network-light +version: 0.1.0.5 +synopsis: A slimmed down version of network +description: A slimmed down version of network, that works with both GHC and MHS. Very incomplete -- pull-requests welcome. +license: Apache-2.0 +license-file: LICENSE +author: Robert Krook +maintainer: robert@krook.dev +copyright: 2025 Robert Krook +category: Network +build-type: Simple +extra-doc-files: CHANGELOG.md +bug-reports: https://github.com/Rewbert/network-light/issues +tested-with: GHC ==9.10.3 + || ==9.12.2 + || ==9.14.1 + MHS ==0.16.4.0 +-- extra-source-files: + +source-repository head + type: git + location: https://github.com/Rewbert/network-light + +flag zephyr + description: Use the Zephyr RTOS sockaddr_in ABI + default: False + manual: True + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: System.Network + other-modules: System.Network.Types + -- other-extensions: + if flag(zephyr) + cpp-options: -DZEPHYR + build-depends: base >=4.20 && <5, bytestring >=0.12.2.0 && <0.13 + hs-source-dirs: src + default-language: Haskell2010 + +Test-Suite test-sockaddr-storable + type: exitcode-stdio-1.0 + Default-language: Haskell2010 + hs-source-dirs: test/Network + main-is: SockAddr.hs + build-depends: base, network-light, QuickCheck diff --git a/src/System/Network.hs b/src/System/Network.hs new file mode 100644 --- /dev/null +++ b/src/System/Network.hs @@ -0,0 +1,327 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE CApiFFI #-} +{- | This module exports everything you need to engage with network-light. The +API is, in many places, similar to that of the standard Network package. However, this +package is smaller and works with both MicroHs and GHC. It is not intended to replace +or improve upon network, but is rather deliberately kept simple. + +It exports a basic API to create and use sockets, and some helper functions that +send and receive ByteString. + +The data types modeling the addressing families, socket options etc, are not complete. +They mirror what we've needed for our purposes, but please make a fork and open a PR to +add what you need, and I will gladly merge it. + +At some point the hope is that MicroHs will be able to compile all of network, but until +then, using this library is the quickest work-around. +-} +module System.Network + ( -- * Data types + {- | @Socket@s are created by @socket@ or @accept@. When you get them, they are already configured to + be non-blocking.-} + Socket + , Domain(..) + , StreamType(..) + , SockOpt(..) + , SockAddr + , mkSockAddr + + -- * Basic operations + , socket + , setsocketopt + , close + , connect + , connect' + , bind + , accept + , listen + -- * Sending data + , sendBuf + , sendBufFull + , sendString + , sendByteString + -- * Receiving data + , recvBuf + , recvString + , recvByteString + , recvByteStringFull + ) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS +import Data.Word + +#ifdef __MHS__ +import System.IO.FD (waitForReadFD, waitForWriteFD) +#endif + +import Foreign.C.Error +import Foreign.C.String +import Foreign.C.Types +import Foreign.Marshal.Alloc +import Foreign.Marshal.Utils +import Foreign.Ptr +import Foreign.Storable + +import System.Network.Types + +-- --------------------------------------------------------------------------- +-- FFI +-- --------------------------------------------------------------------------- + +type FD = CInt + +foreign import ccall "sys/socket.h socket" c_socket :: CInt -> CInt -> CInt -> IO FD +-- connect/accept/send/recv can block for an unbounded time (waiting on +-- a peer), so they're "safe": under GHC with -threaded, a safe call +-- runs on its own OS thread instead of blocking the whole capability, +-- so other Haskell threads (e.g. forkIO'd connection handlers) keep +-- running. A single capability is enough -- no +RTS -N2 needed. mhs +-- accepts the same "safe" keyword but doesn't need it: its own +-- concurrency comes from non-blocking sockets plus waitForReadFD / +-- waitForWriteFD, independent of this annotation. +foreign import ccall safe "sys/socket.h connect" c_connect :: FD -> Ptr SockAddr -> CInt -> IO CInt +foreign import ccall "sys/socket.h bind" c_bind :: FD -> Ptr SockAddr -> CInt -> IO CInt +foreign import ccall safe "sys/socket.h accept" c_accept :: FD -> Ptr SockAddr -> Ptr CInt -> IO FD +foreign import ccall "sys/socket.h listen" c_listen :: FD -> CInt -> IO CInt +foreign import ccall safe "sys/socket.h send" c_send :: FD -> Ptr Word8 -> CSize -> CInt -> IO CInt +foreign import ccall safe "sys/socket.h recv" c_recv :: FD -> Ptr Word8 -> CSize -> CInt -> IO CInt +foreign import ccall "sys/socket.h setsockopt" c_setsockopt :: FD -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt +foreign import ccall "unistd.h close" c_close :: FD -> IO CInt + +#ifdef __MHS__ +foreign import ccall "fcntl.h fcntl" c_fcntl :: CInt -> CInt -> CInt -> IO CInt +foreign import ccall "sys/socket.h getsockopt" c_getsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> Ptr CInt -> IO CInt + +foreign import capi "fcntl.h value F_SETFL" f_SETFL :: CInt +foreign import capi "fcntl.h value O_NONBLOCK" o_NONBLOCK :: CInt + +fdInt :: CInt -> Int +fdInt = fromIntegral + +-- | Read SO_ERROR after a non-blocking connect completes. +peekSockError :: CInt -> IO CInt +peekSockError fd = + alloca $ \errPtr -> alloca $ \lenPtr -> do + poke lenPtr (cSizeOf (0 :: CInt)) + _ <- c_getsockopt fd sOL_SOCKET sO_ERROR errPtr lenPtr + peek errPtr +#endif + +foreign import capi "sys/socket.h value SOL_SOCKET" sOL_SOCKET :: CInt +foreign import capi "sys/socket.h value SO_REUSEADDR" sO_REUSEADDR :: CInt +foreign import capi "sys/socket.h value SO_DEBUG" sO_DEBUG :: CInt +foreign import capi "sys/socket.h value SO_TYPE" sO_TYPE :: CInt +foreign import capi "sys/socket.h value SO_ERROR" sO_ERROR :: CInt + + +-- --------------------------------------------------------------------------- +-- Operations +-- --------------------------------------------------------------------------- + +-- | Create a new socket. +socket :: Domain -> StreamType -> IO Socket +socket d st = do + fd <- throwErrnoIfMinus1 "socket" $ + c_socket (cFromEnum d) (cFromEnum st) 0 +#ifdef __MHS__ + let sock = Socket fd + setsocketopt (Socket fd) O_NONBLOCK (error "do not evaluate") +#endif + return (Socket fd) + +-- | Set a socket option. There should probably be a @getsocketopt@ as well, but there isn't for now. +setsocketopt :: Socket -> SockOpt -> Int -> IO () +#ifdef __MHS__ +setsocketopt (Socket fd) O_NONBLOCK _ = + throwErrnoIfMinus1_ "setsocketopt/O_NONBLOCK" $ + c_fcntl fd f_SETFL o_NONBLOCK +#else +setsocketopt _ O_NONBLOCK _ = return () -- sockets created via GHC already have this setting from the IO manager? +#endif +setsocketopt (Socket fd) so value = + with (fromIntegral value :: CInt) $ \ opt -> + throwErrnoIfMinus1_ "setsocketopt" $ do + let (option, level) = case so of + SO_REUSEADDR -> (sO_REUSEADDR, sOL_SOCKET) + SO_DEBUG -> (sO_DEBUG, sOL_SOCKET) + SO_TYPE -> (sO_TYPE, sOL_SOCKET) + c_setsockopt fd level option opt (cSizeOf (0 :: CInt)) + +-- | Close a socket. +close :: Socket -> IO () +close (Socket fd@(CInt n)) = + throwErrnoIfMinus1_ ("close socket " ++ show n) $ + c_close fd + +-- | Connect. Throws on failure. +connect :: Socket -> SockAddr -> IO () +connect (Socket fd) sockaddr = +#ifdef __MHS__ + with sockaddr $ \p -> do + r <- c_connect fd p (cSizeOf sockaddr) + if r /= -1 then return () else do + errno <- getErrno + if errno == eINPROGRESS + then do waitForWriteFD (fdInt fd) + err <- peekSockError fd + if err /= 0 then do + setErrno (Errno err) + throwErrno "connect" + else + return () + else throwErrno "connect" +#else + with sockaddr $ \p -> + throwErrnoIfMinus1_ "connect" $ + c_connect fd p (cSizeOf sockaddr) +#endif + +-- | Same as 'connect', but returns @False@ rather than throwing on error. +connect' :: Socket -> SockAddr -> IO Bool +connect' (Socket fd) sockaddr = +#ifdef __MHS__ + with sockaddr $ \p -> do + r <- c_connect fd p (cSizeOf sockaddr) + if r /= -1 then return True else do + errno <- getErrno + if errno == eINPROGRESS + then do waitForWriteFD (fdInt fd) + err <- peekSockError fd + return (err == 0) + else return False +#else + with sockaddr $ \p -> do + CInt e <- c_connect fd p (cSizeOf sockaddr) + return (e >= 0) +#endif + +-- | Bind a socket to an address. +bind :: Socket -> SockAddr -> IO () +bind (Socket fd) sockaddr = + with sockaddr $ \p -> + throwErrnoIfMinus1_ "bind" $ + c_bind fd p (cSizeOf sockaddr) + +-- | Accept an incoming connection. The returned 'Socket' is already in non-blocking mode. +accept :: Socket -> IO (Socket, SockAddr) +accept (Socket serverFd) = +#ifdef __MHS__ + allocaBytes (sizeOf (undefined :: SockAddr)) $ \p -> + with (cSizeOf (undefined :: SockAddr)) $ \pSize -> + go p pSize + where + go p pSize = do + r <- c_accept serverFd p pSize + if r /= -1 + then do addr <- peek p + throwErrnoIfMinus1_ "accept/setnonblock" $ + c_fcntl r f_SETFL o_NONBLOCK + return (Socket r, addr) + else do errno <- getErrno + if errno == eAGAIN || errno == eWOULDBLOCK + then waitForReadFD (fdInt serverFd) >> go p pSize + else throwErrno "accept" +#else + allocaBytes (sizeOf (undefined :: SockAddr)) $ \p -> + with (cSizeOf (undefined :: SockAddr)) $ \pSize -> do + clientFd <- throwErrnoIfMinus1 "accept" $ + c_accept serverFd p pSize + addr <- peek p + return (Socket clientFd, addr) +#endif + +-- | Set the socket to listening mode. +listen :: Socket -> Int -> IO () +listen (Socket fd) n = + throwErrnoIfMinus1_ "listen" $ + c_listen fd (fromIntegral n) + +-- | Send raw bytes. Returns the number of bytes that were actually sent. +sendBuf :: Socket -> Ptr Word8 -> Int -> IO Int +#ifdef __MHS__ +sendBuf (Socket fd) buf len = go + where + go = do + CInt n <- c_send fd buf (CSize (fromIntegral len)) (CInt 0) + if n /= -1 then return (fromIntegral n) else do + errno <- getErrno + if errno == eAGAIN || errno == eWOULDBLOCK + then waitForWriteFD (fdInt fd) >> go + else throwErrno "sendBuf" +#else +sendBuf (Socket fd) buf len = + throwErrnoIfMinus1 "sendBuf" $ do + CInt n <- c_send fd buf (CSize (fromIntegral len)) (CInt 0) + return (fromIntegral n) +#endif + +-- | Send raw bytes. Sends the total number of bytes. +sendBufFull :: Socket -> Ptr Word8 -> Int -> IO () +sendBufFull sock ptr len | len == 0 = return () + | otherwise = do + n <- sendBuf sock ptr len + sendBufFull sock (plusPtr ptr n) (len - n) + +-- | A helper function that behaves like 'sendBufFull', but which takes a 'String' rather than a pointer to a buffer. +sendString :: Socket -> String -> IO Int +sendString sock str = + withCAStringLen str $ \(ptr, len) -> + sendBuf sock (castPtr ptr) len + +-- | A helper function that behaves like 'sendBufFull', but which takes a 'ByteString' rather than a pointer to a buffer. +sendByteString :: Socket -> BS.ByteString -> IO () +sendByteString sock bs = + BS.unsafeUseAsCStringLen bs $ \ (ptr, len) -> + sendBufFull sock (castPtr ptr) len + +-- | @recvBuf socket buf len@ -- read at most @len@ bytes from @socket@ into @buf@. Returns the number of bytes that was read. +recvBuf :: Socket -> Ptr Word8 -> Int -> IO Int +#ifdef __MHS__ +recvBuf (Socket fd) buf len = go + where + go = do + CInt n <- c_recv fd buf (CSize (fromIntegral len)) (CInt 0) + if n /= -1 then return (fromIntegral n) else do + errno <- getErrno + if errno == eAGAIN || errno == eWOULDBLOCK + then waitForReadFD (fdInt fd) >> go + else throwErrno "recvBuf" +#else +recvBuf (Socket fd) buf len = + throwErrnoIfMinus1 "recvBuf" $ do + CInt n <- c_recv fd buf (CSize (fromIntegral len)) (CInt 0) + return (fromIntegral n) +#endif + +-- | @recvBufFull socket buf len@ -- read exactly len bytes from @socket@ into @buf@. +recvBufFull :: Socket -> Ptr Word8 -> Int -> IO () +recvBufFull sock ptr len | len == 0 = return () + | otherwise = do + n <- recvBuf sock ptr len + recvBufFull sock (plusPtr ptr n) (len - n) + +-- | @recvString socket len@ -- Receive up to @len@ bytes and decode as a 'String'. +recvString :: Socket -> Int -> IO String +recvString sock maxLen = + allocaBytes maxLen $ \buf -> do + n <- recvBuf sock buf maxLen + peekCAStringLen (castPtr buf, n) + +-- | @recvByteString socket len@ -- read at most @len@ bytes and decode as a 'ByteString'. +recvByteString :: Socket -> Int -> IO BS.ByteString +recvByteString sock maxLen = + allocaBytes maxLen $ \buf -> do + n <- recvBuf sock buf maxLen + BS.packCStringLen (castPtr buf, n) + +-- | @recvByteStringFull socket len@ -- read exactly @len@ bytes and decode as a 'ByteString'. +recvByteStringFull :: Socket -> Int -> IO BS.ByteString +recvByteStringFull sock len = do + buf <- mallocBytes len + recvBufFull sock buf len +#ifdef __MHS__ + BS.unsafePackMallocCStringLen (castPtr buf) len +#else + BS.unsafePackMallocCStringLen (castPtr buf, len) +#endif diff --git a/src/System/Network/Types.hs b/src/System/Network/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/Network/Types.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE CPP #-} +-- | Shared types, instances, and pure helpers used by both +-- "Network.Blocking" and "Network.NonBlocking". +-- +-- Two values here describe the platform @struct sockaddr_in@ ABI and differ +-- between Linux and Zephyr. They are selected with the @ZEPHYR@ CPP macro, +-- which the Zephyr build passes via @mhs -XCPP -DZEPHYR@ (plain @__MHS__@ is +-- defined on both targets and so cannot tell them apart): +-- +-- * @AF_INET@: 2 on Linux, 1 (@NET_AF_INET@) on Zephyr. +-- * @sizeof(struct sockaddr_in)@: 16 on Linux (8 + @sin_zero@), 8 on Zephyr +-- (@net_sockaddr_in@ has no padding). +-- +-- The field order and endianness are identical on both, so 'peekSockAddr' is +-- platform-neutral. +module System.Network.Types + ( Socket(..) + , Domain(..) + , StreamType(..) + , SockAddr(..) + , SockOpt(..) + , mkSockAddr + , cSizeOf + , cFromEnum + ) where + +import Data.Bits +import Data.List +import Data.Word + +import Foreign.C.Types +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable + +-- | A socket file descriptor. +newtype Socket = Socket CInt + deriving (Eq, Ord, Show) + +-- | The domain models addressing families. Only IPv4 is support right now, but more can easily be added. +data Domain + = AF_INET -- ^ IPv4 + +instance Enum Domain where +#if defined(ZEPHYR) + toEnum 1 = AF_INET + toEnum _ = error "Domain.toEnum: unrecognised value" + fromEnum AF_INET = 1 +#else + toEnum 2 = AF_INET + toEnum _ = error "Domain.toEnum: unrecognised value" + fromEnum AF_INET = 2 +#endif + +-- | The stream type used by a socket +data StreamType + = SOCK_STREAM -- ^ TCP + | SOCK_DGRAM -- ^ UDP + +instance Enum StreamType where + toEnum 1 = SOCK_STREAM + toEnum 2 = SOCK_DGRAM + toEnum _ = error "StreamType.toEnum: unrecognised value" + fromEnum SOCK_STREAM = 1 + fromEnum SOCK_DGRAM = 2 + +{- | Socket address. Internals are intentionally opaque to callers. +Create values of this type via 'mkSockAddr'.-} +data SockAddr = SockAddrInet Int String deriving (Show, Read, Ord, Eq) + +{- | Construct a 'SockAddr' from a port and an address. E.g. to create a socket to +target localhost, post 3232, you call @mkSockAddr 3232 "127.0.0.1"@. + +Pass 'Nothing' for the address to get @INADDR_ANY@ (@0.0.0.0@). -} +mkSockAddr :: Int -> Maybe String -> SockAddr +mkSockAddr port (Just address) = SockAddrInet port address +mkSockAddr port Nothing = SockAddrInet port "0.0.0.0" + +-- | Socket options for use with @setsocketopt@. +data SockOpt + = SO_REUSEADDR -- ^ Allow binding to a local address left in @TIME_WAIT@ + -- by a previous socket, so a restarted listener does not + -- fail with @EADDRINUSE@. + | SO_DEBUG -- ^ Enable kernel-level debug tracing for the socket. + | SO_TYPE -- ^ The socket's type (e.g. @SOCK_STREAM@ vs + -- @SOCK_DGRAM@). Note: this is a get-only option on + -- POSIX; passing it to 'setsocketopt' is not meaningful + -- and will typically fail. + | O_NONBLOCK -- ^ Put the socket into non-blocking mode. Not a + -- @SOL_SOCKET@ option: 'setsocketopt' special-cases it, + -- applying it via @fcntl@\/@F_SETFL@ on the MHS runtime + -- and treating it as a no-op under GHC, whose IO manager + -- already runs sockets non-blocking. + +-- --------------------------------------------------------------------------- +-- Storable SockAddr +-- --------------------------------------------------------------------------- + +instance Storable SockAddr where +#if defined(ZEPHYR) + sizeOf _ = 8 +#else + sizeOf _ = 16 +#endif + alignment _ = 16 + peek = peekSockAddr + poke = pokeSockAddr + +-- | Serialise a 'SockAddr' into a @struct sockaddr_in@ laid out in memory. +-- Only 'AF_INET' is supported; the @sin_family@ field is set per platform +-- (see the module header for the @ZEPHYR@ macro). +pokeSockAddr :: Ptr SockAddr -> SockAddr -> IO () +pokeSockAddr p (SockAddrInet port address) = + pokeArray (castPtr p) (sin_family ++ sin_port ++ sin_addr) + where + sin_family :: [Word8] +#if defined(ZEPHYR) + sin_family = [0x01, 0x00] +#else + sin_family = [0x02, 0x00] +#endif + + sin_port :: [Word8] + sin_port = + let high = fromIntegral ((port `shiftR` 8) .&. 0xFF) + low = fromIntegral (port .&. 0xFF) + in [high, low] + + sin_addr :: [Word8] + sin_addr = take 4 $ map read $ splitOn '.' address + where + splitOn :: Eq a => a -> [a] -> [[a]] + splitOn _ [] = [] + splitOn sep xs = + let pref = takeWhile (/= sep) xs + suff = dropWhile (/= sep) xs + in case suff of + [] -> [pref] + (_:t) -> pref : splitOn sep t + +-- | Deserialise a @struct sockaddr_in@ from memory into a 'SockAddr'. +-- Reads the port from bytes 2–3 (network byte order) and the IPv4 address +-- from bytes 4–7. +peekSockAddr :: Ptr SockAddr -> IO SockAddr +peekSockAddr p = do + xs <- peekArray 8 (castPtr p :: Ptr Word8) + case xs of + _:_:high:low:sin_addr -> + let port = (fromIntegral high `shiftL` 8) .|. fromIntegral low + address = intercalate "." $ map show sin_addr + in return $ SockAddrInet port address + _ -> error "peekSockAddr: unexpected buffer layout" + +-- --------------------------------------------------------------------------- +-- Shared helpers +-- --------------------------------------------------------------------------- + +-- | Return the 'sizeOf' of a value as a 'CInt', for passing to C functions. +cSizeOf :: Storable a => a -> CInt +cSizeOf = CInt . fromIntegral . sizeOf + +-- | Convert a Haskell 'Enum' value to a 'CInt', for passing to C functions. +cFromEnum :: Enum a => a -> CInt +cFromEnum = CInt . fromIntegral . fromEnum diff --git a/test/Network/SockAddr.hs b/test/Network/SockAddr.hs new file mode 100644 --- /dev/null +++ b/test/Network/SockAddr.hs @@ -0,0 +1,40 @@ +module Main where + +import Data.List +import Data.Word +import Foreign.Marshal.Utils +import Foreign.Ptr +import Foreign.Storable + +import System.Exit + +import System.Network.Types + +import Test.QuickCheck +import Test.QuickCheck.Monadic + +instance Arbitrary SockAddr where + arbitrary = do + address <- (intercalate "." . map show) <$> vectorOf 4 (arbitrary :: Gen Word8) + port <- chooseInt (1, 9999) + return $ SockAddrInet port address + +prop_pokepeek :: SockAddr -> Property +prop_pokepeek sockaddr = monadicIO $ do + sockaddr' <- run $ with sockaddr $ \p -> do + peek p + + monitor $ whenFail $ do + putStrLn "==== input ====" + putStrLn $ show sockaddr + putStrLn "==== output ====" + putStrLn $ show sockaddr' + + assert $ sockaddr == sockaddr' + +main :: IO () +main = do + r <- quickCheckResult $ withMaxSuccess 10000 prop_pokepeek + if isSuccess r + then exitSuccess + else exitFailure