network-light (empty) → 0.1.0.5
raw patch · 6 files changed
+618/−0 lines, 6 filesdep +QuickCheckdep +basedep +bytestring
Dependencies added: QuickCheck, base, bytestring, network-light
Files
- CHANGELOG.md +25/−0
- LICENSE +13/−0
- network-light.cabal +49/−0
- src/System/Network.hs +327/−0
- src/System/Network/Types.hs +164/−0
- test/Network/SockAddr.hs +40/−0
+ CHANGELOG.md view
@@ -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.
+ LICENSE view
@@ -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.
+ network-light.cabal view
@@ -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
+ src/System/Network.hs view
@@ -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
+ src/System/Network/Types.hs view
@@ -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
+ test/Network/SockAddr.hs view
@@ -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