State.hs

{-# LANGUAGE RecordWildCards #-}

module Hans.IP4.State (
    IP4State(..),
    SendSource(..),
    ResponderRequest(..),
    newIP4State,
    HasIP4State(..),
    addRoute,
    lookupRoute4,
    isLocalAddr,
    nextIdent,
    routesForDev,
  ) where

import           Hans.Config (Config(..))
import           Hans.Device.Types (Device(..))
import           Hans.Ethernet (Mac)
import           Hans.IP4.ArpTable (ArpTable,newArpTable)
import           Hans.IP4.Fragments (FragTable,newFragTable)
import           Hans.IP4.Packet (IP4,IP4Ident)
import qualified Hans.IP4.RoutingTable as RT
import           Hans.Lens
import           Hans.Network.Types (NetworkProtocol)


import qualified Control.Concurrent.BoundedChan as BC
import qualified Data.ByteString.Lazy as L
import           Data.IORef (IORef,newIORef,atomicModifyIORef',readIORef)
import           System.Random (StdGen,newStdGen,Random(random))


-- IP4 State -------------------------------------------------------------------

data SendSource = SourceAny
                  -- ^ Any interface that will route the message

                | SourceIP4 !IP4
                  -- ^ The interface with this address

                | SourceDev !Device !IP4
                  -- ^ This device with this source address


data ResponderRequest = Finish !Device !Mac [L.ByteString]
                        -- ^ Finish sending these IP4 packets

                      | Send !SendSource !IP4 !Bool !NetworkProtocol L.ByteString
                       -- ^ Send this IP4 payload to this address


data IP4State = IP4State { ip4Routes :: !(IORef RT.RoutingTable)
                           -- ^ Addresses currently assigned to devices.

                         , ip4ArpTable :: !ArpTable
                           -- ^ The ARP cache.

                         , ip4Fragments :: !FragTable
                           -- ^ IP4 packet fragments

                         , ip4ArpRetry :: {-# UNPACK #-} !Int
                           -- ^ Arp retry count

                         , ip4ArpRetryDelay :: {-# UNPACK #-} !Int

                         , ip4ResponderQueue :: !(BC.BoundedChan ResponderRequest)

                         , ip4RandomSeed :: !(IORef StdGen)
                         }

newIP4State :: Config -> IO IP4State
newIP4State cfg =
  do ip4Routes         <- newIORef RT.empty
     ip4ArpTable       <- newArpTable cfg
     ip4Fragments      <- newFragTable cfg
     ip4ResponderQueue <- BC.newBoundedChan 32
     ip4RandomSeed     <- newIORef =<< newStdGen
     return IP4State { ip4ArpRetry      = cfgArpRetry cfg
                     , ip4ArpRetryDelay = cfgArpRetryDelay cfg * 1000
                     , .. }

class HasIP4State state where
  ip4State :: Getting r state IP4State

instance HasIP4State IP4State where
  ip4State = id
  {-# INLINE ip4State #-}


addRoute :: HasIP4State state => state -> Bool -> RT.Route -> IO ()
addRoute state = \ defRoute route ->
  atomicModifyIORef' ip4Routes (\ table -> (RT.addRule defRoute route table, ()))
  where
  IP4State { .. } = view ip4State state


-- | Lookup the source address, as well as the next hop and device.
lookupRoute4 :: HasIP4State state => state -> IP4 -> IO (Maybe (IP4,IP4,Device))
lookupRoute4 state = \ dest ->
  do routes <- readIORef ip4Routes
     case RT.lookupRoute dest routes of
       Just route -> return (Just ( RT.routeSource route
                                  , RT.routeNextHop dest route
                                  , RT.routeDevice route))
       Nothing    -> return Nothing
  where
  IP4State { .. } = view ip4State state


-- | Is this an address that's assigned to a device in the network stack?
isLocalAddr :: HasIP4State state => state -> IP4 -> IO (Maybe RT.Route)
isLocalAddr state = \ dst ->
  do rt <- readIORef ip4Routes
     return $! RT.isLocal dst rt
  where
  IP4State { .. } = view ip4State state


-- | Give back the result of using the 'random' function on the internal state.
nextIdent :: HasIP4State state => state -> IO IP4Ident
nextIdent state =
  atomicModifyIORef' ip4RandomSeed (\g -> case random g of (a,g') -> (g',a) )
  where
  IP4State { .. } = view ip4State state


-- | Give back the list of routing rules associated with this device.
routesForDev :: HasIP4State state => state -> Device -> IO [RT.Route]
routesForDev state dev =
  do routes <- readIORef (ip4Routes (view ip4State state))
     return $! RT.routesForDev dev routes