fix(Network.Gopher): give client time to close client socket

After sending the response, we now send TCP FIN by calling shutdown(2)
on the socket. We then wait up to 1 second for the client to finish
reading and closing the socket on their end before finally closing the
socket on our side. This prevents read broken pipes for clients like
curl which would occasionally happen.

Resolves #42.

4 files changed, 71 insertions, 7 deletions

diff --git a/spacecookie.cabal b/spacecookie.cabal
index f65f2a4..a32926d 100644
--- a/spacecookie.cabal
+++ b/spacecookie.cabal
@@ -63,7 +63,9 @@ library
                      , Network.Gopher.Util
   other-modules:       Network.Gopher.Types
                      , Network.Gopher.Log
+                     , Network.Gopher.Util.Socket
   build-depends:       hxt-unicode
+                     , async >= 2.2
   ghc-options:         -Wall -Wno-orphans
 
 test-suite test
diff --git a/spacecookie.nix b/spacecookie.nix
index 5e6acbc..e1cdfbf 100644
--- a/spacecookie.nix
+++ b/spacecookie.nix
@@ -1,7 +1,8 @@
-{ mkDerivation, aeson, attoparsec, base, bytestring, containers
-, directory, download-curl, fast-logger, filepath-bytestring
-, hxt-unicode, lib, mtl, process, socket, systemd, tasty
-, tasty-expected-failure, tasty-hunit, text, transformers, unix
+{ mkDerivation, aeson, async, attoparsec, base, bytestring
+, containers, directory, download-curl, fast-logger
+, filepath-bytestring, hxt-unicode, lib, mtl, process, socket
+, systemd, tasty, tasty-expected-failure, tasty-hunit, text
+, transformers, unix
 }:
 mkDerivation {
   pname = "spacecookie";
@@ -18,11 +19,11 @@ mkDerivation {
     filepath-bytestring mtl socket systemd text transformers unix
   ];
   testHaskellDepends = [
-    attoparsec base bytestring containers directory download-curl
+    async attoparsec base bytestring containers directory download-curl
     filepath-bytestring process tasty tasty-expected-failure
     tasty-hunit
   ];
   homepage = "https://github.com/sternenseemann/spacecookie";
-  description = "Gopher Library and Server Daemon";
+  description = "Gopher Server Library and Daemon";
   license = lib.licenses.gpl3;
 }
diff --git a/src/Network/Gopher.hs b/src/Network/Gopher.hs
index 3f1fb80..00f7804 100644
--- a/src/Network/Gopher.hs
+++ b/src/Network/Gopher.hs
@@ -86,6 +86,7 @@ import Network.Gopher.Log
 import Network.Gopher.Types
 import Network.Gopher.Util
 import Network.Gopher.Util.Gophermap
+import Network.Gopher.Util.Socket
 
 import Control.Concurrent (forkIO, ThreadId ())
 import Control.Exception (bracket, catch, handle, throw, SomeException (), Exception ())
@@ -383,7 +384,7 @@ acceptAndHandle sock = do
       <> toGopherLogStr (show (e :: SocketException))
     Right (clientSock, addr) -> do
       logInfo $ "New connection from " <> makeSensitive (toGopherLogStr addr)
-      void $ forkGopherM (handleIncoming clientSock addr) (close clientSock)
+      void $ forkGopherM (handleIncoming clientSock addr) (gracefulClose clientSock)
 
 -- | Like 'runGopher', but may not cause effects in 'IO' (or anywhere else).
 runGopherPure :: GopherConfig -> (GopherRequest -> GopherResponse) -> IO ()
diff --git a/src/Network/Gopher/Util/Socket.hs b/src/Network/Gopher/Util/Socket.hs
new file mode 100644
index 0000000..023aa1d
--- /dev/null
+++ b/src/Network/Gopher/Util/Socket.hs
@@ -0,0 +1,60 @@
+-- | Internal socket utilities implementing missing
+--   features of 'System.Socket' which are yet to be
+--   upstreamed.
+module Network.Gopher.Util.Socket
+  ( gracefulClose
+  ) where
+
+import Control.Concurrent.MVar (withMVar)
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async (race)
+import Control.Exception.Base (throwIO)
+import Control.Monad (void, when)
+import Data.Functor ((<&>))
+import Foreign.C.Error (Errno (..), getErrno)
+import Foreign.C.Types (CInt (..))
+import System.Socket (receive, msgNoSignal, SocketException (..))
+import System.Socket.Type.Stream (Stream ())
+import System.Socket.Protocol.TCP (TCP ())
+import System.Socket.Unsafe (Socket (..))
+
+-- Until https://github.com/lpeterse/haskell-socket/pull/67 gets
+-- merged, we have to implement shutdown ourselves.
+foreign import ccall unsafe "shutdown"
+  c_shutdown :: CInt -> CInt -> IO CInt
+
+data ShutdownHow
+  -- | Disallow Reading (calls to 'receive' are empty).
+  = ShutdownRead
+  -- | Disallow Writing (calls to 'send' throw).
+  | ShutdownWrite
+  -- | Disallow both.
+  | ShutdownReadWrite
+  deriving (Show, Eq, Ord, Enum)
+
+-- | Shutdown a stream connection (partially).
+--   Will send TCP FIN and prompt a client to
+--   close the connection.
+--
+--   Not exposed to prevent future name clash.
+shutdown :: Socket a Stream TCP -> ShutdownHow -> IO ()
+shutdown (Socket mvar) how = withMVar mvar $ \fd -> do
+  res <- c_shutdown (fromIntegral fd)
+    $ fromIntegral $ fromEnum how
+  when (res /= 0) $ throwIO =<<
+    (getErrno <&> \(Errno errno) -> SocketException errno)
+
+-- | Shutdown connection and give client a bit
+--   of time to clean up on its end before closing
+--   the connection to avoid a broken pipe on the
+--   other side.
+gracefulClose :: Socket a Stream TCP -> IO ()
+gracefulClose sock = do
+  -- send TCP FIN
+  shutdown sock ShutdownWrite
+  -- wait for some kind of read from the
+  -- client (either mempty, meaning TCP FIN,
+  -- something else which would mean protocol
+  -- violation). Give up after 1s.
+  _ <- race (void $ receive sock 16 msgNoSignal) (threadDelay 1000000)
+  pure ()