summaryrefslogtreecommitdiff
path: root/dht/src/Network/SocketLike.hs
blob: 2c97ddd4f122f6961996403aaae865dfe8540da0 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE CPP #-}
-- |
--
-- 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)
import Control.Arrow

-- | 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)

    -- | Is the socket still valid? Connected
    --
    --   In order to give the instance writer
    --   the option to do book-keeping in a pure
    --   type, a conceptually modified version of
    --   the 'SocketLike' is returned.
    --
    isValidSocket :: sock -> IO (sock,Bool)


instance SocketLike NS.Socket where
    getSocketName = NS.getSocketName
    getPeerName   = NS.getPeerName
--  getPeerCred   = NS.getPeerCred
#if MIN_VERSION_network(3,1,0)
    isValidSocket s = (s,) <$> NS.withFdSocket s (return . (/= (-1)))
#else
#if MIN_VERSION_network(3,0,0)
    isValidSocket s = (s,) . (/= (-1)) <$> NS.fdSocket s
#else
#if MIN_VERSION_network(2,4,0)
    isValidSocket s = (s,) . NS.isConnected s -- warning: this is always False if the socket
                                              --          was converted to a Handle
#else
    isValidSocket  = (s,) . NS.sIsConnected s -- warning: this is always False if the socket
                                              --          was converted to a Handle
#endif
#endif
#endif

-- | 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
    isValidSocket rs@(Restricted mb sock) = maybe (first (Restricted mb) <$> isValidSocket sock) (((rs,) <$>) .  hIsOpen) 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