1 files changed, 104 insertions, 0 deletions

diff --git a/src/Network/SocketLike.hs b/src/Network/SocketLike.hs
new file mode 100644
index 00000000..2aa78e3e
--- /dev/null
+++ b/src/Network/SocketLike.hs
@@ -0,0 +1,104 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+-- |
+--
+-- A socket could be used indirectly via a 'System.IO.Handle' or a conduit from
+-- Michael Snoyman's conduit package.  But doing so presents an encapsulation
+-- problem.  Do we allow access to the underlying socket and trust that it wont
+-- be used in an unsafe way?  Or do we protect it at the higher level and deny
+-- access to various state information?
+--
+-- The 'SocketLike' class enables the approach that provides a safe wrapper to
+-- the underlying socket and gives access to various state information without
+-- enabling direct reads or writes.
+module Network.SocketLike
+    ( SocketLike(..)
+    , RestrictedSocket
+    , restrictSocket
+    , restrictHandleSocket
+    -- * Re-exports
+    --
+    -- | To make the 'SocketLike' methods less awkward to use, the types
+    -- 'CUInt', 'SockAddr', and 'PortNumber' are re-exported.
+    , CUInt
+    , PortNumber
+    , SockAddr(..)
+    ) where
+
+import Network.Socket
+    ( PortNumber
+    , SockAddr
+    )
+import Foreign.C.Types ( CUInt )
+
+import qualified Network.Socket as NS
+import System.IO (Handle,hClose,hIsOpen)
+
+-- | A safe (mostly read-only) interface to a 'NS.Socket'.  Note that despite
+-- how this class is named, it provides no access to typical 'NS.Socket' uses
+-- like sending or receiving network packets.
+class SocketLike sock where
+    -- | See 'NS.getSocketName'
+    getSocketName :: sock -> IO SockAddr
+    -- | See 'NS.getPeerName'
+    getPeerName   :: sock -> IO SockAddr
+    -- | See 'NS.getPeerCred'
+    getPeerCred   :: sock -> IO (CUInt, CUInt, CUInt)
+    -- | See 'NS.socketPort'
+    socketPort    :: sock -> IO PortNumber
+    -- | See 'NS.sIsConnected'
+    --
+    -- __Warning__: Don't rely on this method if it's possible the socket was
+    -- converted into a 'Handle'.
+    sIsConnected  :: sock -> IO Bool
+    -- | See 'NS.sIsBound'
+    sIsBound      :: sock -> IO Bool
+    -- | See 'NS.sIsListening'
+    sIsListening  :: sock -> IO Bool
+    -- | See 'NS.sIsReadable'
+    sIsReadable   :: sock -> IO Bool
+    -- | See 'NS.sIsWritable'
+    sIsWritable   :: sock -> IO Bool
+
+    -- | This is the only exposed write-access method to the
+    -- underlying state.  Usually implemented by 'NS.close'
+    sClose        :: sock -> IO ()
+
+instance SocketLike NS.Socket where
+    getSocketName = NS.getSocketName
+    getPeerName   = NS.getPeerName
+    getPeerCred   = NS.getPeerCred
+    socketPort    = NS.socketPort
+    sIsConnected  = NS.sIsConnected -- warning: this is always False if the socket
+                                    --          was converted to a Handle
+    sIsBound      = NS.sIsBound
+    sIsListening  = NS.sIsListening
+    sIsReadable   = NS.sIsReadable
+    sIsWritable   = NS.sIsWritable
+
+    sClose        = NS.sClose
+
+-- | An encapsulated socket.  Data reads and writes are not possible.
+data RestrictedSocket = Restricted (Maybe Handle) NS.Socket deriving Show
+
+instance SocketLike RestrictedSocket where
+    getSocketName (Restricted mb sock) = NS.getSocketName sock
+    getPeerName   (Restricted mb sock) = NS.getPeerName sock
+    getPeerCred   (Restricted mb sock) = NS.getPeerCred sock
+    socketPort    (Restricted mb sock) = NS.socketPort sock
+    sIsConnected  (Restricted mb sock) = maybe (NS.sIsConnected sock) (hIsOpen) mb
+    sIsBound      (Restricted mb sock) = NS.sIsBound sock
+    sIsListening  (Restricted mb sock) = NS.sIsListening sock
+    sIsReadable   (Restricted mb sock) = NS.sIsReadable sock
+    sIsWritable   (Restricted mb sock) = NS.sIsWritable sock
+    sClose        (Restricted mb sock) = maybe (NS.sClose sock) (\h -> hClose h >> NS.sClose sock) mb
+
+-- | Create a 'RestrictedSocket' that explicitly disallows sending or
+-- receiving data.
+restrictSocket :: NS.Socket -> RestrictedSocket
+restrictSocket socket = Restricted Nothing socket
+
+-- | Build a 'RestrictedSocket' for which 'sClose' will close the given
+-- 'Handle'.  It is intended that this 'Handle' was obtained via
+-- 'NS.socketToHandle'.
+restrictHandleSocket :: Handle ->  NS.Socket -> RestrictedSocket
+restrictHandleSocket h socket = Restricted (Just h) socket