Types.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}

module Hans.Socket.Types where

import Hans.Addr (isWildcardAddr)
import Hans.Device.Types (Device)
import Hans.Network (Network(..),RouteInfo(..))
import Hans.Types (HasNetworkStack,NetworkStack)

import           Control.Exception (Exception,throwIO)
import qualified Data.ByteString.Lazy as L
import           Data.Typeable (Typeable)
import           Data.Word (Word16)


-- Socket Addresses ------------------------------------------------------------

type SockPort = Word16


-- Generic Socket Operations ---------------------------------------------------

data SocketConfig = SocketConfig { scRecvBufferSize :: !Int
                                   -- ^ Bytes to buffer
                                 } deriving (Show)

defaultSocketConfig :: SocketConfig
defaultSocketConfig  = SocketConfig { scRecvBufferSize = 4096 }

class Socket sock where

  -- | Close an open socket.
  sClose :: Network addr => sock addr -> IO ()


class (DataSocket (Client sock), Socket sock) => ListenSocket sock where

  type Client sock :: * -> *

  -- | Create a listening socket, with a backlog of n.
  sListen :: (HasNetworkStack ns, Network addr)
          => ns -> SocketConfig -> addr -> SockPort -> Int -> IO (sock addr)

  sAccept :: Network addr => sock addr -> IO (Client sock addr)


class Socket sock => DataSocket sock where

  -- | Connect this socket to one on a remote machine.
  sConnect :: (HasNetworkStack ns, Network addr)
           => ns
           -> SocketConfig
           -> Maybe Device
           -> addr           -- ^ Local address
           -> Maybe SockPort -- ^ Local port
           -> addr           -- ^ Remote host
           -> SockPort       -- ^ Remote port
           -> IO (sock addr)

  -- | Returns True iff there is currently space in the buffer to accept a
  -- write. Note, this is probably a bad thing to count on in a concurrent
  -- system ...
  sCanWrite :: Network addr => sock addr -> IO Bool

  -- | Send a chunk of data on a socket.
  sWrite :: Network addr => sock addr -> L.ByteString -> IO Int

  -- | Returns True iff there is data in the buffer that can be read.
  -- Note, this is probably a bad thing to count on in a concurrent
  -- system ...
  sCanRead :: Network addr => sock addr -> IO Bool

  -- | Read a chunk of data from a socket. Reading an empty result indicates
  -- that the socket has closed.
  sRead :: Network addr => sock addr -> Int -> IO L.ByteString

  -- | Non-blocking read from a socket. Reading an empty result means that the
  -- socket has closed, while reading a 'Nothing' result indicates that there
  -- was no data available.
  sTryRead :: Network addr => sock addr -> Int -> IO (Maybe L.ByteString)


-- Exceptions ------------------------------------------------------------------

data ConnectionException = AlreadyConnected
                           -- ^ This connection already exists.

                         | NoConnection
                           -- ^ No information about the other end of the
                           -- socket was present.

                         | NoPortAvailable
                           -- ^ All ports are in use.

                         | ConnectionRefused

                         | ConnectionClosing

                         | DoesNotExist
                           -- ^ The connection is already closed.
                           deriving (Show,Typeable)

data ListenException = AlreadyListening
                       -- ^ Something is already listening on this
                       -- host/port combination.
                       deriving (Show,Typeable)

data RoutingException = NoRouteToHost
                        -- ^ It's not possible to reach this host from this
                        -- source address.
                        deriving (Show,Typeable)

instance Exception ConnectionException
instance Exception ListenException
instance Exception RoutingException


-- Utilities -------------------------------------------------------------------

-- | Raise an exception when no route can be found to the destination.
route :: Network addr
      => NetworkStack -> Maybe Device -> addr -> addr -> IO (RouteInfo addr)

route ns mbDev src dst =
  do mbRoute <- route' ns mbDev src dst
     case mbRoute of
       Just ri -> return ri
       Nothing -> throwIO NoRouteToHost


-- | Return source routing information, when a route exists to the destination.
route' :: Network addr
       => NetworkStack -> Maybe Device -> addr -> addr
       -> IO (Maybe (RouteInfo addr))

route' ns mbDev src dst =
  do mbRoute <- lookupRoute ns dst
     case mbRoute of
       Just ri | maybe True (riDev ri ==) mbDev
                 && (src == riSource ri || isWildcardAddr src) ->
                 return (Just ri)

       _ -> return Nothing