Fixing unix socket on 2.8

Network/Socket.hsc

@@ -641,6 +641,7 @@ accept sock@(MkSocket s family stype protocol status) = do
    else do
      let sz = sizeOfSockAddrByFamily family
      allocaBytes sz $ \ sockaddr -> do
+     zeroMemory sockaddr $ fromIntegral sz
 #if defined(mingw32_HOST_OS)
      new_sock <-
         if threaded

Network/Socket/Types.hsc

@@ -904,6 +904,15 @@ withNewSockAddr family f = do
     let sz = sizeOfSockAddrByFamily family
     allocaBytes sz $ \ptr -> f ptr sz
 
+-- We cannot bind sun_paths longer than than the space in the sockaddr_un
+-- structure, and attempting to do so could overflow the allocated storage
+-- space.  This constant holds the maximum allowable path length.
+--
+#if defined(DOMAIN_SOCKET_SUPPORT)
+unixPathMax :: Int
+unixPathMax = #const sizeof(((struct sockaddr_un *)NULL)->sun_path)
+#endif
+
 -- We can't write an instance of 'Storable' for 'SockAddr' because
 -- @sockaddr@ is a sum type of variable size but
 -- 'Foreign.Storable.sizeOf' is required to be constant.
@@ -914,21 +923,15 @@ withNewSockAddr family f = do
 -- | Write the given 'SockAddr' to the given memory location.
 pokeSockAddr :: Ptr a -> SockAddr -> IO ()
 #if defined(DOMAIN_SOCKET_SUPPORT)
-pokeSockAddr p (SockAddrUnix path) = do
-#if defined(darwin_HOST_OS)
-    zeroMemory p (#const sizeof(struct sockaddr_un))
-#else
-    case path of
-      ('\0':_) -> zeroMemory p (#const sizeof(struct sockaddr_un))
-      _        -> return ()
-#endif
+pokeSockAddr p sa@(SockAddrUnix path) = do
+    when (length path > unixPathMax) $ error "pokeSockAddr: path is too long"
+    zeroMemory p $ fromIntegral $ sizeOfSockAddr sa
 #if defined(HAVE_STRUCT_SOCKADDR_SA_LEN)
     (#poke struct sockaddr_un, sun_len) p ((#const sizeof(struct sockaddr_un)) :: Word8)
 #endif
     (#poke struct sockaddr_un, sun_family) p ((#const AF_UNIX) :: CSaFamily)
     let pathC = map castCharToCChar path
-        poker = case path of ('\0':_) -> pokeArray; _ -> pokeArray0 0
-    poker ((#ptr struct sockaddr_un, sun_path) p) pathC
+    pokeArray ((#ptr struct sockaddr_un, sun_path) p) pathC
 #endif
 pokeSockAddr p (SockAddrInet port addr) = do
 #if defined(darwin_HOST_OS)

tests/Network/SocketSpec.hs

@@ -6,6 +6,7 @@ module Network.SocketSpec (main, spec) where
 import Control.Concurrent.MVar (readMVar)
 import Control.Monad
 import Network.Socket hiding (recv, send)
+import Network.Socket.ByteString
 import Network.Test.Common
 
 import Test.Hspec
@@ -98,3 +99,28 @@ spec = do
         it "does not cause segfault on macOS 10.8.2 due to AI_NUMERICSERV" $ do
             let hints = defaultHints { addrFlags = [AI_NUMERICSERV] }
             void $ getAddrInfo (Just hints) (Just "localhost") Nothing
+
+    describe "unix sockets" $ do
+        it "basic unix sockets end-to-end" $ do
+            when isUnixDomainSocketAvailable $ do
+                let client sock = send sock testMsg
+                    server (sock, addr) = do
+                      recv sock 1024 `shouldReturn` testMsg
+                      addr `shouldBe` (SockAddrUnix "")
+                unixTest client server
+#ifdef linux_HOST_OS
+        it "can end-to-end with an abstract socket" $ do
+            when isUnixDomainSocketAvailable $ do
+                let
+                    abstractAddress = toEnum 0:"/haskell/network/abstract"
+                    clientAct sock = send sock testMsg
+                    server (sock, addr) = do
+                      recv sock 1024 `shouldReturn` testMsg
+                      addr `shouldBe` (SockAddrUnix "")
+                unixTestWith abstractAddress (const $ return ()) clientAct server
+        it "safely throws an exception" $ do
+            when isUnixDomainSocketAvailable $ do
+                let abstractAddress = toEnum 0:"/haskell/network/abstract-longlonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglong"
+                sock <- socket AF_UNIX Stream defaultProtocol
+                bind sock (SockAddrUnix abstractAddress) `shouldThrow` anyErrorCall
+#endif

tests/Network/Test/Common.hs

@@ -7,9 +7,10 @@ module Network.Test.Common
   , testMsg
   , lazyTestMsg
   , tcpTest
+  , tcpTestUsingClient
   , unixTest
+  , unixTestWith
   , udpTest
-  , tcpTestUsingClient
   ) where
 
 import Control.Concurrent (ThreadId, forkIO, myThreadId)
@@ -42,31 +43,39 @@ unixAddr = "/tmp/network-test"
 -- client and server.  'unixTest' makes sure that the 'Socket' is
 -- closed after the actions have run.
 unixTest :: (Socket -> IO a) -> ((Socket, SockAddr) -> IO b) -> IO ()
-unixTest clientAct serverAct =
+unixTest = unixTestWith unixAddr unlink
+  where
+    unlink file = do
+        exist <- doesFileExist file
+        when exist $ removeFile file
+
+unixTestWith
+    :: String -- ^ address
+    -> (String -> IO ()) -- ^ clean up action
+    -> (Socket -> IO a) -- ^ client action
+    -> ((Socket, SockAddr) -> IO b) -- ^ server action
+    -> IO ()
+unixTestWith address cleanupAct clientAct serverAct =
     test clientSetup clientAct serverSetup server
   where
     clientSetup = do
         sock <- socket AF_UNIX Stream defaultProtocol
-        connect sock (SockAddrUnix unixAddr)
+        connect sock (SockAddrUnix address)
         return sock
 
     serverSetup = do
         sock <- socket AF_UNIX Stream defaultProtocol
-        unlink unixAddr -- just in case
-        bind sock (SockAddrUnix unixAddr)
+        cleanupAct address -- just in case
+        bind sock (SockAddrUnix address)
         listen sock 1
         return sock
 
     server sock = E.bracket (accept sock) (killClientSock . fst) serverAct
 
-    unlink file = do
-        exist <- doesFileExist file
-        when exist $ removeFile file
-
     killClientSock sock = do
         shutdown sock ShutdownBoth
         close sock
-        unlink unixAddr
+        cleanupAct address
 
 -- | Establish a connection between client and server and then run
 -- 'clientAct' and 'serverAct', in different threads.  Both actions