Permalink
Browse files

Model the buddy list and messages from QML.

No longer contain replicated state in QML.
  • Loading branch information...
creichert committed May 7, 2014
1 parent 933c45a commit f3175e939fa5c10735e5fcdeec02a9383fa31d74
Showing with 85 additions and 86 deletions.
  1. +32 −41 qml/HSTorChat.qml
  2. +44 −40 src/HSTorChat/GUI.hs
  3. +9 −5 src/HSTorChat/Protocol.hs
View
@@ -5,10 +5,6 @@ Rectangle {
id: root
width: 500; height: 600
ListModel {
id: buddies
}
ListView {
id: buddylist
anchors.left: parent.left
@@ -29,14 +25,29 @@ Rectangle {
model: buddies
delegate: Text {
text: name
width: parent.width
text: modelData.onion
color: "white"
z: 5
MouseArea {
anchors.fill: parent
onClicked: { buddylist.currentIndex = index
msgarea.model = buddies.get(index)["msgs"]
}
onClicked: { buddylist.currentIndex = index }
}
Rectangle {
anchors.right: parent.right
width: 10; height: parent.height
color: { if (modelData.status == "Available")
return "green"
else if (modelData.status == "Handshake")
return "steelblue"
else if (modelData.status == "Away")
return "yellow"
else if (modelData.status == "Xa")
return "orange"
else
return "red"
}
}
}
@@ -77,8 +88,12 @@ Rectangle {
anchors.left: buddylist.right
anchors.margins: 3
clip: true
delegate: Text { text: name
horizontalAlignment: { if (fromme)
verticalLayoutDirection: ListView.BottomToTop
model: { if (buddies[buddylist.currentIndex])
buddies[buddylist.currentIndex].msgs
}
delegate: Text { text: modelData.text
horizontalAlignment: { if (modelData.fromme)
Text.AlignRight
}
width: parent.width
@@ -100,42 +115,18 @@ Rectangle {
anchors.left: buddylist.right
anchors.right: parent.right
anchors.margins: 5
enabled: false
onAccepted: { if (buddylist.length <= 0) return
sendMsg(buddies.get(buddylist.currentIndex)["name"], msgentry.text)
buddies.get(buddylist.currentIndex)["msgs"].append({ name: msgentry.text, fromme: true })
msgarea.model = buddies.get(buddylist.currentIndex)["msgs"]
sendMsg(buddies[buddylist.currentIndex], msgentry.text)
msgentry.text = ""
msgarea.positionViewAtEnd()
msgarea.positionViewAtBeginning()
}
Rectangle {
anchors.fill: parent
border.width: 1; border.color: "darkgrey"
radius: 5
z: -5
}
}
Component.onCompleted: { self.msgReady.connect(msgReceived) }
function msgReceived(msg) {
var buddyFound = false
for (var i=0; i < buddies.count; i++) {
if (buddies.get(i)["name"] == msg.buddy){
buddies.get(i)["msgs"].append({ name: msg.text, fromme: false })
msgarea.model = buddies.get(buddylist.currentIndex)["msgs"]
buddyFound = true
}
}
if (buddyFound == false) {
buddies.append({ "name": msg.buddy, "msgs": [ { name: msg.text, fromme: false } ] })
/* TODO: Focus the buddy. This will make the next call work. */
msgarea.model = buddies.get(buddylist.currentIndex)["msgs"]
msgentry.enabled = true
Rectangle {
anchors.fill: parent
border.width: 1; border.color: "darkgrey"
radius: 5
z: -5
}
msgarea.positionViewAtEnd()
}
}
View
@@ -18,58 +18,65 @@ import HSTorChat.Protocol
data UI = UI
{ _myonion :: Onion
, _mystatus :: BuddyStatus
, _buddies :: MVar [Buddy]
, _buddies :: MVar [ObjRef Buddy]
, _pending :: MVar [PendingConnection]
} deriving Typeable
-- Signals
data ChatMsgReady deriving Typeable
data BuddiesChanged deriving Typeable
instance DefaultClass UI where
classMembers = [
defPropertySigRO "buddies" (Proxy :: Proxy BuddiesChanged)
(readMVar . _buddies . fromObjRef :: ObjRef UI -> IO [ObjRef Buddy])
-- | Return Onion address for this instance of HSTorChat.
defMethod "onion" (return . _myonion . fromObjRef :: ObjRef UI -> IO Onion)
, defMethod "onion" (return . _myonion . fromObjRef :: ObjRef UI -> IO Onion)
-- | Send a message to a buddy.
, defMethod "sendMsg" sendMsg
-- | Add a new buddy.
, defMethod "newBuddy" newBuddy
-- | Access the context object (ObjRef UI) in qml callbacks.
, defPropertyRO "self" (return :: ObjRef UI -> IO (ObjRef UI))
-- | Called when a new message arrives from a buddy.
, defSignal "msgReady" (Proxy :: Proxy ChatMsgReady)
]
instance DefaultClass ChatMsg where
classMembers = [
defPropertyRO "buddy" (return . T.pack . buddy . fromObjRef)
, defPropertyRO "text" (return . T.pack . text . fromObjRef)
, defPropertyRO "fromme" (return . fromme . fromObjRef)
]
instance DefaultClass Buddy where
classMembers = [
defPropertyRO "onion" (return . T.pack . _onion . fromObjRef)
, defPropertyRO "status" (return . T.pack . show . _status . fromObjRef)
, defPropertySigRO "msgs" (Proxy :: Proxy ChatMsgReady)
(readMVar . _msgs . fromObjRef :: ObjRef Buddy -> IO [ObjRef ChatMsg])
]
instance Marshal ChatMsg where
type MarshalMode ChatMsg c d = ModeObjFrom ChatMsg c
marshaller = fromMarshaller fromObjRef
instance Marshal Buddy where
type MarshalMode Buddy c d = ModeObjFrom Buddy c
marshaller = fromMarshaller fromObjRef
instance SignalKeyClass ChatMsgReady where
type SignalParams ChatMsgReady = ObjRef ChatMsg -> IO ()
type SignalParams ChatMsgReady = IO ()
instance SignalKeyClass BuddiesChanged where
type SignalParams BuddiesChanged = IO ()
-- | This method is called when the user enters
-- a msg in a chat window. The handle for the buddy
-- is accessed and used to send the message.
--
-- TODO: Pass Buddy instead of Text -> Text
sendMsg :: ObjRef UI -> T.Text -> T.Text -> IO ()
sendMsg ui onion msg = do
let ui' = fromObjRef ui
buds <- readMVar $ _buddies ui'
sendMsgTo buds
sendMsg :: ObjRef UI -> ObjRef Buddy -> T.Text -> IO ()
sendMsg _ bud msg = do saveMsg $ ChatMsg (T.unpack msg) (_onion $ fromObjRef bud) True
fireSignal (Proxy :: Proxy ChatMsgReady) bud
hPutStrLn (_outConn $ fromObjRef bud) $ formatMsg $ Message msg
where
sendMsgTo [] = putStrLn "Unable to send message. No buddies."
sendMsgTo buds = do
-- Filter proper buddy from list.
let thebuddy = head $ filter (\b -> _onion b == T.unpack onion) buds
-- | TODO: Reschedule if send is not succesful.
hPutStrLn (_outConn thebuddy) $ formatMsg $ Message msg
saveMsg cmsg = modifyMVar_ (_msgs $ fromObjRef bud) (\ms -> do m <- newObjectDC cmsg
return (m:ms))
newBuddy :: ObjRef UI -> T.Text -> IO ()
newBuddy ui onion = do
@@ -110,7 +117,7 @@ handleRequest ui iHdl = do
b' <- readMVar (_buddies ui')
-- Send Ping if this Buddy is new or Offline.
when ((not $ any ((== key) . _pcookie) p') &&
(not $ any ((/= Offline) . _status) b')
(not $ any ((/= Offline) . _status) (map fromObjRef b'))
) $ hPutStrLn oHdl $ formatMsg $ Ping (_myonion ui') cky
mapM_ (hPutStrLn oHdl . formatMsg) [ Pong key
@@ -140,25 +147,22 @@ handleRequest ui iHdl = do
-- | A pending connection exists. Verify and start the buddy
pendingConnection (PendingConnection cke o oHdl:pcs) = do
let b = Buddy (T.unpack o) iHdl oHdl cke Available
ui' = fromObjRef ui
ms <- newMVar []
b <- newObjectDC $ Buddy (T.unpack o) iHdl oHdl cke Available ms
let ui' = fromObjRef ui
modifyMVar_ (_buddies ui') (\bs -> return (b:bs))
-- effectively, remove this pending connection from
-- _pending.
modifyMVar_ (_pending ui') (\_ -> return pcs)
-- A new Buddy has been identified.
m <- newObjectDC $ ChatMsg ("A connection to " ++ T.unpack o ++ " has been established.") $ T.unpack o
-- TODO: Emit the `ProtocolMsg Message` constructor directly.
-- Remove the Msg class and modify MsgReady sig.
fireSignal (Proxy :: Proxy ChatMsgReady) ui m
fireSignal (Proxy :: Proxy BuddiesChanged) ui
-- remove the pending connection.
modifyMVar_ (_pending ui') (\_ -> return pcs)
runBuddy ui b
runBuddy :: ObjRef UI -> Buddy -> IO ()
runBuddy ui (Buddy onion iHdl oHdl cky st) = do
runBuddy :: ObjRef UI -> ObjRef Buddy -> IO ()
runBuddy ui objb = do
let b = fromObjRef objb
iHdl = _inConn b
oHdl = _outConn b
txt <- hGetLine iHdl
rdy <- hReady oHdl
@@ -176,12 +180,12 @@ runBuddy ui (Buddy onion iHdl oHdl cky st) = do
, Status Available
]
Right (Message msg) -> do
-- TODO: Emit the `ProtocolMsg Message` directly.
m <- newObjectDC $ ChatMsg (T.unpack msg) onion
fireSignal (Proxy :: Proxy ChatMsgReady) ui m
cmsg <- newObjectDC $ ChatMsg (T.unpack msg) (_onion b) False
modifyMVar_ (_msgs b) (\ms -> return (cmsg:ms))
fireSignal (Proxy :: Proxy ChatMsgReady) objb
Right p -> print p
hFlush iHdl
hFlush oHdl
runBuddy ui $ Buddy onion iHdl oHdl cky st
runBuddy ui objb
View
@@ -3,12 +3,14 @@
module HSTorChat.Protocol where
import Control.Applicative
import Control.Concurrent
import Control.Monad
import Data.Attoparsec.Text
import qualified Data.Char as C
import qualified Data.Text as T
import Data.Typeable
import Data.Word
import Graphics.QML
import Prelude hiding (take)
import qualified Prelude as P
import Network
@@ -36,7 +38,7 @@ hstorchatHost = "127.0.0.1"
hstorchatOutConn :: Onion -> IO Handle
hstorchatOutConn onion = do
outsock <- socksConnectWith (defaultSocksConf "127.0.0.1" 22209) (T.unpack onion) (PortNumber 11009)
oHdl <- socketToHandle outsock ReadWriteMode
oHdl <- socketToHandle outsock ReadWriteMode
hSetBuffering oHdl LineBuffering
return oHdl
@@ -54,7 +56,8 @@ data Buddy = Buddy
, _outConn :: Handle
, _cookie :: Cookie -- ^ Cookie sent to buddy.
, _status :: BuddyStatus -- * Buddy status
} deriving (Show, Typeable)
, _msgs :: MVar [ObjRef ChatMsg]
} deriving (Typeable)
data BuddyStatus = Offline
| Handshake
@@ -90,9 +93,10 @@ data ProtocolMsg = Ping Onion Cookie
deriving Show
data ChatMsg = ChatMsg
{ text :: String
, buddy :: String
} deriving Typeable
{ text :: String
, buddy :: String
, fromme :: Bool
} deriving (Show, Typeable)
parseResponse :: Parser ProtocolMsg
parseResponse = try parsePingPong

0 comments on commit f3175e9

Please sign in to comment.