pontarius-xpmn-0.0.1.0: Examples/TestDevice.hs
{-
This file (TestDevice.hs) is an example of how to use Pontarius XPMN. The
contents of this file may be used freely, as if it is in the public domain.
-}
import Network.XMPP
import Media.XPMN.DeviceServer
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
import Data.Maybe
import Data.XML.Types
import qualified Data.Text as DT
import System.Random
import qualified Data.Map as DM
data State = State { deviceServer :: DeviceServer
, stateNumbers :: [(String, Integer)]
, pingpongVar :: SimpleVariable Pingpong
, numbersVar :: ComplexVariable Integer
, stateStd :: StdGen
, stateQueries :: [Query Integer] }
data Pingpong = Ping | Pong
instance XMLable Pingpong where
toXML Ping = [NodeElement (Element (Name (DT.pack "ping") Nothing Nothing) (DM.fromList []) [])]
toXML Pong = [NodeElement (Element (Name (DT.pack "pong") Nothing Nothing) (DM.fromList []) [])]
fromXML [NodeElement (Element { elementName = n })] | nameLocalName n == DT.pack "ping" = Ping
fromXML [NodeElement (Element { elementName = n })] | nameLocalName n == DT.pack "pong" = Pong
data InternalEvent = IED DeviceInEvent | IEP Bool deriving (Show)
host = "test.pontarius.org"
user = "sprint3-xpmn"
server = "test.pontarius.org"
port = 5222
resource = "pontarius"
password = ""
main :: IO ()
main =
do -- Connect the XMPP account
deviceServer <- start host port user password resource ["pingpong", "numbers"] ["even-numbers"]
s <- (createSimpleVar deviceServer) "pingpong" Ping []
ids <- mapM (\ _ -> getID) [0..9]
let numbers = zip ids (reverse [0..9])
let com = complexVariable "numbers" numbers []
c <- newChan
forkIO $ lolz (inEvents deviceServer) c
stdGen <- getStdGen
forkIO $ loop (State { deviceServer = deviceServer
, pingpongVar = s
, numbersVar = com
, stateNumbers = numbers
, stateStd = stdGen
, stateQueries = [] }) c
forkIO $ pingpong c
return ()
where
loop :: State -> Chan InternalEvent -> IO ()
loop s c =
do e <- readChan c
putStrLn $ "DeviceTest: Got InternalEvent: " ++ (show e)
s' <- processEvent s e
loop s' c
processEvent :: State -> InternalEvent -> IO State
processEvent s (IED DIEOnline) = do
putStrLn "We are online!"
return s
processEvent s (IED (DIEIncomingSimpleVariableGet j "pingpong")) = do
putStrLn "Hmm3..."
writeChan (outEvents (deviceServer s)) $ DOEIQ (iqResult (Just (SID "todo")) Nothing (Just j) Nothing
(Just (Element { elementName = Name { nameLocalName = DT.pack "simple-variable"
, namePrefix = Nothing
, nameNamespace = Just (DT.pack "urn:xmpp:xpmn:0") }
, elementAttributes = DM.fromList [( Name { nameLocalName = DT.pack "variable"
, namePrefix = Nothing
, nameNamespace = Nothing }
, [ContentText $ DT.pack $ simpleVariableName $ pingpongVar s])]
, elementNodes = (toXML $ simpleVariableValue $ pingpongVar s) })))
-- TODO: iq result { from, to, id}
return s
processEvent s (IED (DIEIncomingSimpleVariableSet j "pingpong" v)) = do
putStrLn "Hmm4..."
pingpongVar' <- (modifySimpleVar $ deviceServer s) (pingpongVar s) (fromXML v)
writeChan (outEvents (deviceServer s)) $ DOEIQ (iqResult (Just (SID "todo")) Nothing (Just j) Nothing Nothing)
-- TODO: iq result { from, to, id}
return s { pingpongVar = pingpongVar' }
processEvent s (IED (DIESubscribe j "pingpong")) = do
pingpongVar' <- (subscribeSimpleVar $ deviceServer s) (pingpongVar s) j
-- TODO: iq result { from, to, id }
return s { pingpongVar = pingpongVar' }
processEvent s (IED (DIEUnsubscribe j "pingpong")) = do
let pingpongVar' = (unsubscribeSimpleVar $ deviceServer s) (pingpongVar s) j
-- TODO: iq result { from, to, id }
return s { pingpongVar = pingpongVar' }
processEvent s (IED (DIESubscribe j "numbers")) = do
let numbersVar' = (subscribeComplexVar $ deviceServer s) (numbersVar s) j
-- TODO: iq result { from, to, id }
return s { numbersVar = numbersVar' }
processEvent s (IED (DIEUnsubscribe j "numbers")) = do
let numbersVar' = (unsubscribeComplexVar $ deviceServer s) (numbersVar s) j
-- TODO: iq result { from, to, id }
return s { numbersVar = numbersVar' }
processEvent s (IED (DIEItems j "numbers")) = do
let numbersValues = complexVariableValue (numbersVar s)
let items = map (\ (i, v) -> NodeElement (Element { elementName = Name { nameLocalName = DT.pack "item"
, namePrefix = Nothing
, nameNamespace = Nothing }
, elementNodes = toXML v
, elementAttributes = ( DM.fromList [(Name { nameLocalName = DT.pack "id"
, namePrefix = Nothing
, nameNamespace = Nothing }, [ContentText (DT.pack i)])])})) numbersValues
writeChan (outEvents (deviceServer s)) $ DOEIQ (iqResult (Just (SID "todo")) Nothing (Just j) Nothing
(Just (Element { elementName = Name { nameLocalName = DT.pack "pubsub"
, namePrefix = Nothing
, nameNamespace = Just (DT.pack "http://jabber.org/protocol/pubsub") }
, elementAttributes = DM.fromList []
, elementNodes = [NodeElement (Element { elementName = Name { nameLocalName = DT.pack "items"
, namePrefix = Nothing
, nameNamespace = Nothing }
, elementAttributes = DM.fromList [(Name { nameLocalName = DT.pack "node"
, namePrefix = Nothing
, nameNamespace = Nothing }, [(ContentText (DT.pack "numbers"))])]
, elementNodes = items } )] })))
return s
processEvent s (IED (DIEQuery j "even-numbers" _)) = do
let que = query j even :: Query Integer
return s { stateQueries = que:(stateQueries s) }
processEvent s (IED (DIEIQ i)) = do
putStrLn $ "Got an IQ that was not processed by DeviceServer: " ++
(show i)
return s
processEvent s (IEP b) = do
-- COMPLEX VAR:
-- get random number and id
let (number, stdGen') = randomR (0 :: Integer, 99) (stateStd s)
idToAdd <- getID
-- get item to remove
let idToRemove = fst (last (complexVariableValue (numbersVar s)))
-- remove id
c <- (retract (deviceServer s)) (numbersVar s) idToRemove
-- add id
c' <- (publish (deviceServer s)) c idToAdd number
-- publish to all queries
q' <- mapM (\ q -> (queryRetract (deviceServer s)) q idToRemove) (stateQueries s)
q'' <- mapM (\ q -> (queryPublish (deviceServer s)) q idToAdd number) (stateQueries s)
case b of
True -> do
case simpleVariableValue (pingpongVar s) of
Ping -> -- Already ping
return s { numbersVar = c', stateStd = stdGen', stateQueries = q'' }
Pong -> do
s' <- (modifySimpleVar (deviceServer s)) (pingpongVar s) Ping
return s { numbersVar = c', pingpongVar = s', stateStd = stdGen', stateQueries = q'' }
False -> do
case simpleVariableValue (pingpongVar s) of
Ping -> do
s' <- (modifySimpleVar (deviceServer s)) (pingpongVar s) Pong
return s { numbersVar = c', pingpongVar = s', stateStd = stdGen', stateQueries = q'' }
Pong -> -- Already pong
return s { numbersVar = c', stateStd = stdGen', stateQueries = q'' }
processEvent s e = do
putStrLn $ "!E!E!E!E!E!E!E!E!E!E!: " ++ (show e)
return s
lolz c c' = do
e <- readChan c
writeChan c' (IED e)
lolz c c'
getFeatures :: [String]
getFeatures = []
pingpong :: Chan InternalEvent -> IO ()
pingpong c = do
threadDelay 5000000
writeChan c (IEP False)
threadDelay 5000000
writeChan c (IEP True)
pingpong c