socket-unix (empty) → 0.1.0.0
raw patch · 6 files changed
+372/−0 lines, 6 filesdep +asyncdep +basedep +bytestringsetup-changed
Dependencies added: async, base, bytestring, socket, socket-unix, tasty, tasty-hunit, unix
Files
- LICENSE +21/−0
- README.md +34/−0
- Setup.hs +2/−0
- socket-unix.cabal +57/−0
- src/System/Socket/Family/Unix.hsc +108/−0
- test/test.hs +150/−0
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2017 Vyacheslav Hashov++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,34 @@+[![Available on Hackage][badge-hackage]][hackage]+[![License MIT][badge-license]][license]+[![Build Status][badge-travis]][travis]+# socket-unix+A Unix domain socket API for the [socket](https://github.com/lpeterse/haskell-socket) library.++## Usage+Creating the Unix domain socket:+```haskell+import System.Socket+import System.Socket.Type.Stream+import System.Socket.Family.Unix++s <- socket :: IO (Socket Unix Stream Unix)+```++Creating the address for binding/connecting+```haskell+address <- case socketAddressUnixPath "example.sock" of+ Just addr -> pure addr+ Nothing -> putStrLn "invalid pathname for socket"+```+### Symlinks+Binding to a socket with a filename creates a socket in the filesystem, but does not unlink it after `close` called. You should handle deleting links yourself.+## Portability+Only Linux is supported.+++[badge-travis]: https://img.shields.io/travis/VyacheslavHashov/haskell-socket-unix.svg+[travis]: https://travis-ci.org/VyacheslavHashov/haskell-socket-unix+[badge-hackage]: https://img.shields.io/hackage/v/socket-unix.svg?dummy+[hackage]: https://hackage.haskell.org/package/socket-unix+[badge-license]: https://img.shields.io/badge/license-MIT-blue.svg?dummy+[license]: https://github.com/vyacheslavhashov/haskell-socket-unix/blob/master/LICENSE
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ socket-unix.cabal view
@@ -0,0 +1,57 @@+name: socket-unix+version: 0.1.0.0+synopsis: A Unix domain sockets+description: A Unix domain socket extension for the socket library+homepage: https://github.com/vyacheslavhashov/haskell-socket-unix#readme+license: MIT +license-file: LICENSE+author: Vyacheslav Hashov+maintainer: vyacheslavhashov@gmail.com+copyright: 2017 Vyacheslav Hashov+category: System, Network+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: System.Socket.Family.Unix+ build-depends: base >= 4.7 && < 5+ , socket >= 0.6.0.0 && < 0.8.0.0+ , bytestring >= 0.10.0.0 && < 0.11++ ghc-options: -Wall+ default-language: Haskell2010++test-suite default+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: test.hs+ build-depends: base >= 4.7 && < 5+ , socket >= 0.6.0.0 && < 0.8.0.0+ , socket-unix+ , tasty >= 0.11 && < 0.12+ , tasty-hunit >= 0.9 && < 0.10+ , bytestring >= 0.10.0.0 && < 0.11+ , unix >= 2.7 && < 3.0+ , async >= 2.0 && < 2.3+ default-language: Haskell2010++test-suite threaded+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: test.hs+ build-depends: base >= 4.7 && < 5+ , socket >= 0.6.0.0 && < 0.8.0.0+ , socket-unix+ , tasty >= 0.11 && < 0.12+ , tasty-hunit >= 0.9 && < 0.10+ , bytestring >= 0.10.0.0 && < 0.11+ , unix >= 2.7 && < 3.0+ , async >= 2.0 && < 2.3+ ghc-options: -threaded+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/vyacheslavhashov/haskell-socket-unix
+ src/System/Socket/Family/Unix.hsc view
@@ -0,0 +1,108 @@+-- |+-- Stability : experimental+-- Portability : Linux++{-# language TypeFamilies #-}+{-# language FlexibleInstances #-}++module System.Socket.Family.Unix+ ( Unix+ , SocketAddress+ , socketAddressUnixPath+ , socketAddressUnixAbstract+ , getUnixPath+ ) where++import Foreign.Ptr (castPtr, plusPtr)+import Foreign.Storable (Storable(..))+import Foreign.Marshal.Utils (fillBytes, copyBytes)++import Data.Word (Word16, Word8)+import Data.ByteString (ByteString)+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)+import qualified Data.ByteString as B++import System.Socket (Family(..), SocketAddress, Protocol(..))++#include "hs_socket.h"++#if __GLASGOW_HASKELL__ < 800+#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)+#endif++-- | The [Unix domain socket]+-- (https://en.wikipedia.org/wiki/Unix_domain_socket)+data Unix++instance Family Unix where+ familyNumber _ = (#const AF_UNIX)++instance Protocol Unix where+ protocolNumber _ = 0++-- | A Unix socket address+data instance SocketAddress Unix+ -- | Address is connected to a filesystem pathname. When used to bind+ -- a socket file with this name is created in the file system.+ = SocketAddressUnixPath ByteString+ -- | Address is in abstract namespace which is a Linux-specific feature+ -- that allows us to bind a UNIX domain socket to a name without that+ -- name being created in the file system.+ | SocketAddressUnixAbstract ByteString+ deriving (Eq, Show)++-- | The maximal length of a address path.+-- SUSv3 doesn’t specify the size of the sun_path field. Early BSD+-- implementations used 108 and 104 bytes, and one contemporary implementation+-- (HP-UX 11) uses 92 bytes. On linux it is declared as+-- > char sun_path[108];+-- and 1 byte is reserved for null byte.+maxPathLength :: Int+maxPathLength = 107++-- | Creates address which is connected to a filesystem pathname.+-- Returns Nothing if @path@'s length exceeds maximal supported.+socketAddressUnixPath :: ByteString -> Maybe (SocketAddress Unix)+socketAddressUnixPath path+ | B.length path <= maxPathLength = Just $ SocketAddressUnixPath path+ | otherwise = Nothing++-- | Creates address with name in abstract namespace.+-- Returns Nothing if @path@'s length exceeds maximal supported.+socketAddressUnixAbstract :: ByteString -> Maybe (SocketAddress Unix)+socketAddressUnixAbstract path+ | len <= maxPathLength = Just . SocketAddressUnixAbstract $+ path `B.append` B.replicate (maxPathLength - len) 0+ | otherwise = Nothing+ where len = B.length path++-- | Returns filesystem pathname where address is connected to.+getUnixPath :: SocketAddress Unix -> Maybe (ByteString)+getUnixPath (SocketAddressUnixPath path) = Just path+getUnixPath _ = Nothing++-- For implementation details see @man unix@+instance Storable (SocketAddress Unix) where+ sizeOf _ = (#size struct sockaddr_un)+ alignment _ = (#alignment struct sockaddr_un)++ peek ptr = do+ first <- peek (sun_path ptr) :: IO Word8+ case first of+ 0 -> SocketAddressUnixAbstract <$>+ B.packCStringLen (castPtr $ sun_path ptr `plusPtr` 1, maxPathLength)+ _ -> SocketAddressUnixPath <$> B.packCString (castPtr $ sun_path ptr)+ where+ sun_path = (#ptr struct sockaddr_un, sun_path)++ poke ptr socketAddress = do+ fillBytes ptr 0 (#const sizeof(struct sockaddr_un))+ poke (sun_family ptr) ((#const AF_UNIX) :: Word16)+ case socketAddress of+ SocketAddressUnixPath path -> unsafeUseAsCStringLen path $+ \(src, len) -> copyBytes (sun_path ptr) src len+ SocketAddressUnixAbstract path -> unsafeUseAsCStringLen path $+ \(src, len) -> copyBytes (sun_path ptr `plusPtr` 1) src len+ where+ sun_family = (#ptr struct sockaddr_un, sun_family)+ sun_path = (#ptr struct sockaddr_un, sun_path)
+ test/test.hs view
@@ -0,0 +1,150 @@+{-# language OverloadedStrings #-}+module Main where++import Control.Concurrent.Async (async, wait)+import Control.Exception (bracket, throwIO, try)+import Control.Monad (when)+import Data.Maybe (fromJust)+import Data.String (IsString)+import Data.ByteString (ByteString)+import System.Posix.Files (removeLink, fileExist)+import Test.Tasty+import Test.Tasty.HUnit++import System.Socket+import System.Socket.Type.Stream+import System.Socket.Type.Datagram+import System.Socket.Family.Unix+++main :: IO ()+main = defaultMain $ testGroup "unix domain socket"+ [ groupUnixPathname+ , groupAbstractName ]++groupUnixPathname :: TestTree+groupUnixPathname = testGroup "Unix path name"+ [ testCase "connect to non-existing path name" $ bracket+ unixSocketStream+ close+ (\s -> do+ r <- try $ connect s addr+ case r of+ Left e | e == SocketException 2 -> return ()+ | otherwise -> throwIO e+ Right () -> assertFailure "connection should have failed"+ )++ , testCase "server\\client stream" $ bracket+ ( (,) <$> unixSocketStream <*> unixSocketStream)+ closeSockets+ (testServerClientStream addr)++ , testCase "server\\client datagram" $ bracket+ ((,) <$> unixSocketDatagram <*> unixSocketDatagram)+ closeSockets+ (testServerClientDatagram addr cAddr)+ ]+ where+ addr = fromJust $ socketAddressUnixPath unixPath+ cAddr = fromJust $ socketAddressUnixPath clientUnixPath+ closeSockets (server, client) = do+ close server+ close client+ unlink unixPath+ unlink clientUnixPath+ -- Sockets with real pathname should be unlinked after closing+ unlink path = fileExist path >>= flip when (removeLink path)++groupAbstractName :: TestTree+groupAbstractName = testGroup "Abstract path name"+ [ testCase "connect to non-existing path name" $ bracket+ unixSocketStream+ close+ (\s -> do+ r <- try $ connect s addr+ case r of+ Left e | e == eConnectionRefused -> return ()+ | otherwise -> throwIO e+ Right () -> assertFailure "connection should have failed"+ )+ , testCase "server\\client stream" $ bracket+ ( (,) <$> unixSocketStream <*> unixSocketStream)+ closeSockets+ (testServerClientStream addr)+ , testCase "server\\client datagram" $ bracket+ ((,) <$> unixSocketDatagram <*> unixSocketDatagram)+ closeSockets+ (testServerClientDatagram addr cAddr)+ ]+ where+ addr = fromJust $ socketAddressUnixAbstract abstractPath+ cAddr = fromJust $ socketAddressUnixAbstract clientAbstractPath+ closeSockets (server, client) = do+ close server+ close client+++clientMessage :: ByteString+clientMessage = "client message"++serverMessage :: ByteString+serverMessage = "server message"++unixPath :: IsString a => a+unixPath = "Woum5ag3oohuaLee.socket"++clientUnixPath :: IsString a => a+clientUnixPath = "Io4meo0epoquashi.socket"++abstractPath :: ByteString+abstractPath = "/tmp/uth4Aechiereejae.socket"++clientAbstractPath :: ByteString+clientAbstractPath = "/tmp/FieNg4shamo4Thie.socket"++unixSocketStream :: IO (Socket Unix Stream Unix)+unixSocketStream = socket++unixSocketDatagram :: IO (Socket Unix Datagram Unix)+unixSocketDatagram = socket++testServerClientStream+ :: SocketAddress Unix+ -> (Socket Unix Stream Unix, Socket Unix Stream Unix)+ -> IO ()+testServerClientStream addr (server, client) = do+ bind server addr+ listen server 5+ serverRecv <- async $ do+ (peerSock, peerAddr) <- accept server+ r <- receive peerSock 4096 mempty+ send peerSock serverMessage mempty+ pure r+ connect client addr+ send client clientMessage mempty++ clientMessageReceived <- wait serverRecv+ serverMessageReceived <- receive client 4096 mempty+ clientMessageReceived @?= clientMessage+ serverMessageReceived @?= serverMessage++testServerClientDatagram+ :: SocketAddress Unix+ -> SocketAddress Unix+ -> (Socket Unix Datagram Unix, Socket Unix Datagram Unix)+ -> IO ()+testServerClientDatagram sAddr cAddr (server, client) = do+ bind server sAddr+ bind client cAddr+ serverRecv <- async $ do+ (r, peerAddr) <- receiveFrom server 4096 mempty+ sendTo server serverMessage mempty peerAddr+ pure r+ sendTo client clientMessage mempty sAddr++ clientMessageReceived <- wait serverRecv+ serverMessageReceived <- receive client 4096 mempty+ clientMessageReceived @?= clientMessage+ serverMessageReceived @?= serverMessage+