Verified Commit 16c68a2c authored by Allele Dev's avatar Allele Dev

core: point-free API, add CanSend/CanRecv

parent fdbf0c19
......@@ -5,6 +5,7 @@ module Network.Typed.Socket (
SocketProtocol(..),
SockAddr(..),
SocketStatus(..),
ShutdownStatus(..),
socket,
connect,
......@@ -43,6 +44,9 @@ import Control.Monad
import qualified Network.Socket as NS
import qualified Network.Socket.ByteString as NSB
--------------------------------------------------------------------------------
-- Core Data Types
--------------------------------------------------------------------------------
-- Socket family singletons
data SocketFamily
= Unix
......@@ -78,8 +82,11 @@ data SockAddr (f :: SocketFamily) where
NS.PortNumber -> !NS.FlowInfo -> !NS.HostAddress6 -> !NS.ScopeID -> SockAddr 'InetV6
SockAddrUnix :: ![Char] -> SockAddr 'Unix
socket :: forall f p sh.
(SockFam f, SockProto p) => IO (SSocket f p 'Unconnected sh)
--------------------------------------------------------------------------------
-- Core operations
--------------------------------------------------------------------------------
socket :: forall f p.
(SockFam f, SockProto p) => IO (SSocket f p 'Unconnected 'Available)
socket =
let x = socketFamily (socketFamily1 :: SocketFamily1 f)
y = socketProtocol (sockProto1 :: SocketProtocol1 p)
......@@ -90,28 +97,30 @@ close :: Closeable s ~ 'True =>
close (SSocket s) = NS.close s >> return (SSocket s)
connect ::
SSocket f 'Tcp 'Unconnected sh -> SockAddr f
SockAddr f -> SSocket f 'Tcp 'Unconnected sh
-> IO (SSocket f 'Tcp 'Connected 'Available)
connect (SSocket s) addr =
connect addr (SSocket s) =
NS.connect s (toNetworkSockAddr addr) >> return (SSocket s)
bind :: SSocket f p 'Unconnected sh -> SockAddr f -> IO (SSocket f p 'Bound sh)
bind (SSocket s) addr =
bind :: SockAddr f -> SSocket f p 'Unconnected sh -> IO (SSocket f p 'Bound sh)
bind addr (SSocket s) =
NS.bind s (toNetworkSockAddr addr) >> return (SSocket s)
listen :: SSocket f 'Tcp 'Bound sh -> Int -> IO (SSocket f 'Tcp 'Listening sh)
listen (SSocket s) n = NS.listen s n >> return (SSocket s)
listen :: Int -> SSocket f 'Tcp 'Bound sh -> IO (SSocket f 'Tcp 'Listening sh)
listen n (SSocket s) = NS.listen s n >> return (SSocket s)
accept :: SSocket f 'Tcp 'Listening sh -> IO (SSocket f 'Tcp 'Connected sh, NS.SockAddr)
accept (SSocket s) = do
(s', a) <- NS.accept s
return (SSocket s', a)
send :: SSocket f 'Tcp 'Connected sh -> ByteString -> IO Int
send (SSocket s) bs = NSB.send s bs
send :: CanSend sh ~ 'True
=> ByteString -> SSocket f 'Tcp 'Connected sh -> IO Int
send bs (SSocket s) = NSB.send s bs
recv :: SSocket f 'Tcp 'Connected sh -> Int -> IO ByteString
recv (SSocket s) n = NSB.recv s n
recv :: CanReceive sh ~ 'True
=> Int -> SSocket f 'Tcp 'Connected sh -> IO ByteString
recv n (SSocket s) = NSB.recv s n
shutdownReceive ::
CanShutdownReceive sh ~ 'True =>
......@@ -135,46 +144,47 @@ shutdownBoth (SSocket s) =
NS.shutdown s NS.ShutdownBoth >> return (SSocket s)
-- simplified assumptions: require connectionless UDP for sendTo/recvFrom
sendTo :: SSocket f 'Udp 'Unconnected sh -> ByteString -> SockAddr f -> IO Int
sendTo (SSocket s) bs addr =
sendTo :: CanSend sh ~ 'True
=> ByteString -> SockAddr f -> SSocket f 'Udp 'Unconnected sh -> IO Int
sendTo bs addr (SSocket s) =
NSB.sendTo s bs (toNetworkSockAddr addr)
recvFrom ::
SockFam f => SSocket f 'Udp 'Unconnected sh -> Int -> IO (ByteString, SockAddr f)
recvFrom (SSocket s) n = do
recvFrom :: (CanReceive sh ~ 'True, SockFam f)
=> Int -> SSocket f 'Udp 'Unconnected sh -> IO (ByteString, SockAddr f)
recvFrom n (SSocket s) = do
(bs, sa) <- NSB.recvFrom s n
return (bs, fromNetworkSockAddr sa)
-- bracketed, typed helpers
withSocket :: (SockFam f, SockProto p) => (SSocket f p 'Unconnected sh -> IO a) -> IO a
withSocket :: (SockFam f, SockProto p) => (SSocket f p 'Unconnected 'Available -> IO a) -> IO a
withSocket = bracket socket close
withTcp4Socket :: (SSocket 'InetV4 'Tcp 'Unconnected sh -> IO a) -> IO a
withTcp4Socket :: (SSocket 'InetV4 'Tcp 'Unconnected 'Available -> IO a) -> IO a
withTcp4Socket = withSocket
withTcp6Socket :: (SSocket 'InetV6 'Tcp 'Unconnected sh -> IO a) -> IO a
withTcp6Socket :: (SSocket 'InetV6 'Tcp 'Unconnected 'Available -> IO a) -> IO a
withTcp6Socket = withSocket
withTcpUnixSocket :: (SSocket 'Unix 'Tcp 'Unconnected sh -> IO a) -> IO a
withTcpUnixSocket :: (SSocket 'Unix 'Tcp 'Unconnected 'Available -> IO a) -> IO a
withTcpUnixSocket = withSocket
withUdp4Socket :: (SSocket 'InetV4 'Udp 'Unconnected sh -> IO a) -> IO a
withUdp4Socket :: (SSocket 'InetV4 'Udp 'Unconnected 'Available -> IO a) -> IO a
withUdp4Socket = withSocket
withUdp6Socket :: (SSocket 'InetV6 'Udp 'Unconnected sh -> IO a) -> IO a
withUdp6Socket :: (SSocket 'InetV6 'Udp 'Unconnected 'Available -> IO a) -> IO a
withUdp6Socket = withSocket
withUdpUnixSocket :: (SSocket 'Unix 'Udp 'Unconnected sh -> IO a) -> IO a
withUdpUnixSocket :: (SSocket 'Unix 'Udp 'Unconnected 'Available -> IO a) -> IO a
withUdpUnixSocket = withSocket
setSocketOption :: SSocket f p s sh -> NS.SocketOption -> Int -> IO (SSocket f p s sh)
setSocketOption ss@(SSocket s) opt n = NS.setSocketOption s opt n >> return ss
setSocketOption :: NS.SocketOption -> Int -> SSocket f p s sh -> IO (SSocket f p s sh)
setSocketOption opt n ss@(SSocket s) = NS.setSocketOption s opt n >> return ss
makePortReusable :: SSocket f p s sh -> IO (SSocket f p s sh)
makePortReusable s = setSocketOption s NS.ReusePort 0 >> return s
makePortReusable s = setSocketOption NS.ReusePort 0 s >> return s
makeAddrReusable :: SSocket f p s sh -> IO (SSocket f p s sh)
makeAddrReusable s = setSocketOption s NS.ReuseAddr 0 >> return s
makeAddrReusable s = setSocketOption NS.ReuseAddr 0 s >> return s
--------------------------------------------------------------------------------
-- Type machinery to make the above possible
......@@ -261,6 +271,14 @@ type family CanShutdownSend (sh :: ShutdownStatus) :: Bool where
type family CanShutdownBoth (sh :: ShutdownStatus) :: Bool where
CanShutdownBoth 'Available = 'True
type family CanSend (sh :: ShutdownStatus) :: Bool where
CanSend 'Available = 'True
CanSend 'CannotReceive = 'True
type family CanReceive (sh :: ShutdownStatus) :: Bool where
CanReceive 'Available = 'True
CanReceive 'CannotSend = 'True
-- not really used yet
-- it'd be nice to track these at the type-level and also extend the
-- interface so more socket options can be set, rather than just the
......
......@@ -22,23 +22,26 @@ import qualified Network.Socket as NS
serverAddr :: SockAddr 'InetV4
serverAddr = SockAddrInet 2291 (NS.tupleToHostAddress (127,0,0,1))
runServer :: SSocket 'InetV4 'Tcp 'Unconnected sh -> MVar () -> IO ()
runServer s serverWaitLock = do
void (makeAddrReusable s)
sbound <- bind s serverAddr
slistening <- listen sbound 1
putMVar serverWaitLock ()
(client, _) <- accept slistening
bs <- recv client 32
n <- send client bs
serverTest :: SSocket 'InetV4 'Tcp 'Listening 'Available -> IO ()
serverTest server = do
(client, _) <- accept server
bs <- recv 32 client
n <- send bs client
n `shouldBe` 4
return ()
runClient :: SSocket 'InetV4 'Tcp 'Unconnected sh -> IO ()
runServer :: SSocket 'InetV4 'Tcp 'Unconnected 'Available -> MVar () -> IO ()
runServer s serverWaitLock =
makeAddrReusable s
>>= bind serverAddr
>>= listen 1
>>= (\server -> putMVar serverWaitLock () >> serverTest server)
runClient :: SSocket 'InetV4 'Tcp 'Unconnected 'Available -> IO ()
runClient s = do
sconnected <- connect s serverAddr
n <- send sconnected "fish"
bs <- recv sconnected 32
client <- connect serverAddr s
n <- send "fish" client
bs <- recv 32 client
n `shouldBe` 4
bs `shouldBe` "fish"
......@@ -48,20 +51,25 @@ main = hspec $ do
describe "Network.Typed.Socket" $ do
it "can open and close a tcp4 socket" $ do
s <- (socket :: IO (SSocket 'InetV4 'Tcp 'Unconnected sh))
void (close s)
(socket :: IO (SSocket 'InetV4 'Tcp 'Unconnected 'Available))
>>= close
>> return ()
it "can open and close a tcp6 socket" $ do
s <- (socket :: IO (SSocket 'InetV6 'Tcp 'Unconnected sh))
void (close s)
(socket :: IO (SSocket 'InetV6 'Tcp 'Unconnected 'Available))
>>= close
>> return ()
it "can open and close a udp4 socket" $ do
s <- (socket :: IO (SSocket 'InetV4 'Udp 'Unconnected sh))
void (close s)
(socket :: IO (SSocket 'InetV4 'Udp 'Unconnected 'Available))
>>= close
>> return ()
it "can open and close a udp6 socket" $ do
s <- (socket :: IO (SSocket 'InetV6 'Udp 'Unconnected sh))
void (close s)
(socket :: IO (SSocket 'InetV6 'Udp 'Unconnected 'Available))
>>= close
>> return ()
it "can echo server" $ do
withTcp4Socket $ \server -> do
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment