module Network.Linx.Gateway
( Gateway (..)
, HostName
, PortID (..)
, Signal (..)
, SigNo (..)
, SignalSelector (..)
, Pid
, Timeout (..)
, create
, destroy
, hunt
, receiveWithTimeout
, receive
, sendWithSender
, sendWithSelf
, attach
, detach
, askName
, withGateway
) where
import Control.Applicative ((<$>))
import Control.Exception (bracket)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBSC
import Data.Maybe (fromJust)
import Network (HostName, PortID (..), connectTo)
import Network.Socket (withSocketsDo)
import Network.Linx.Gateway.Message
( Message (..)
, Header (..)
, ProtocolPayload (..)
, PayloadType (..)
, encode
, mkInterfaceRequest
, mkCreateRequest
, mkDestroyRequest
, mkHuntRequest
, mkReceiveRequest
, mkSendRequest
, mkAttachRequest
, mkDetachRequest
, mkNameRequest
, headerSize
, decodeHeader
, decodeProtocolPayload
)
import Network.Linx.Gateway.Signal
( Signal (..)
, SignalSelector (..)
)
import Network.Linx.Gateway.Types
( Version (..)
, Status (..)
, Flags (..)
, Length (..)
, Pid (..)
, Timeout (..)
, SigNo (..)
, Attref (..)
, CString (..)
, mkCString
)
import System.IO (Handle)
data Gateway =
Gateway {
handle :: !Handle
, self :: !Pid
, maxSignal :: !Length
, accept :: ![PayloadType]}
deriving (Show, Eq)
create :: String -> HostName -> PortID -> IO Gateway
create name' hostname port =
withSocketsDo $ do
gw <- connectTo hostname port
createReply <- expectPayload gw =<< talkGateway gw (mkCreateRequest name')
ifReply <- expectPayload gw
=<< talkGateway gw (mkInterfaceRequest V100 BigEndian)
return $ Gateway gw (pid createReply)
(maxSigSize createReply)
(payloadTypes ifReply)
destroy :: Gateway -> IO ()
destroy gw = do
_ <- expectPayload (handle gw)
=<< talkGateway (handle gw) (mkDestroyRequest (self gw))
return ()
hunt :: Gateway -> String -> Signal -> IO (Maybe Pid)
hunt gw client signal' = do
reply <- expectPayload (handle gw)
=<< talkGateway (handle gw) (mkHuntRequest signal' (mkCString client))
let pid' = pid reply
return $
case pid' of
Pid 0 -> Nothing
_ -> Just pid'
receiveWithTimeout :: Gateway -> Timeout -> SignalSelector
-> IO (Maybe (Pid, Signal))
receiveWithTimeout gw tmo sigSel' = do
reply <- expectPayload (handle gw)
=<< talkGateway (handle gw) (mkReceiveRequest tmo sigSel')
return $
case reply of
ReceiveReply Success (Pid 0) (Pid 0) NoSignal -> Nothing
ReceiveReply Success senderPid' _ signal' ->
Just (senderPid', signal')
_ -> Nothing
receive :: Gateway -> SignalSelector -> IO (Pid, Signal)
receive gw sigSel' = fromJust <$> receiveWithTimeout gw Infinity sigSel'
sendWithSender :: Gateway -> Pid -> Pid -> Signal -> IO ()
sendWithSender gw fromPid' destPid' signal' = do
_ <- expectPayload (handle gw)
=<< talkGateway (handle gw) (mkSendRequest fromPid' destPid' signal')
return ()
sendWithSelf :: Gateway -> Pid -> Signal -> IO ()
sendWithSelf gw = sendWithSender gw (self gw)
attach :: Gateway -> Pid -> Signal -> IO Attref
attach gw pid' signal' = do
reply <- expectPayload (handle gw)
=<< talkGateway (handle gw) (mkAttachRequest pid' signal')
return $ attref reply
detach :: Gateway -> Attref -> IO ()
detach gw attref' = do
_ <- expectPayload (handle gw)
=<< talkGateway (handle gw) (mkDetachRequest attref')
return ()
askName :: Gateway -> IO String
askName gw = do
reply <- expectPayload (handle gw)
=<< talkGateway (handle gw) mkNameRequest
let CString lbs = name reply
return $ LBSC.unpack lbs
withGateway :: String -> HostName -> PortID -> (Gateway -> IO a) -> IO a
withGateway service host port handler =
bracket (create service host port) destroy handler
talkGateway :: Handle -> Message -> IO Header
talkGateway hGw message = do
LBS.hPut hGw $ encode message
decodeHeader <$> readGateway hGw headerSize
expectPayload :: Handle -> Header -> IO ProtocolPayload
expectPayload hGw header =
decodeProtocolPayload (payloadType header)
<$> readGateway hGw (payloadLength header)
readGateway :: Handle -> Length -> IO LBS.ByteString
readGateway hGw (Length len) = LBS.hGet hGw (fromIntegral len)