Skip to content

Commit f3175e9

Browse files
creichertcreichert
committed
Model the buddy list and messages from QML.
No longer contain replicated state in QML.
1 parent 933c45a commit f3175e9

3 files changed

Lines changed: 85 additions & 86 deletions

File tree

‎qml/HSTorChat.qml‎

Lines changed: 32 additions & 41 deletions
Original file line numberDiff line numberDiff line change
@@ -5,10 +5,6 @@ Rectangle {
55
id: root
66
width: 500; height: 600
77

8-
ListModel {
9-
id: buddies
10-
}
11-
128
ListView {
139
id: buddylist
1410
anchors.left: parent.left
@@ -29,14 +25,29 @@ Rectangle {
2925

3026
model: buddies
3127
delegate: Text {
32-
text: name
28+
width: parent.width
29+
text: modelData.onion
3330
color: "white"
3431
z: 5
3532
MouseArea {
3633
anchors.fill: parent
37-
onClicked: { buddylist.currentIndex = index
38-
msgarea.model = buddies.get(index)["msgs"]
39-
}
34+
onClicked: { buddylist.currentIndex = index }
35+
}
36+
37+
Rectangle {
38+
anchors.right: parent.right
39+
width: 10; height: parent.height
40+
color: { if (modelData.status == "Available")
41+
return "green"
42+
else if (modelData.status == "Handshake")
43+
return "steelblue"
44+
else if (modelData.status == "Away")
45+
return "yellow"
46+
else if (modelData.status == "Xa")
47+
return "orange"
48+
else
49+
return "red"
50+
}
4051
}
4152
}
4253

@@ -77,8 +88,12 @@ Rectangle {
7788
anchors.left: buddylist.right
7889
anchors.margins: 3
7990
clip: true
80-
delegate: Text { text: name
81-
horizontalAlignment: { if (fromme)
91+
verticalLayoutDirection: ListView.BottomToTop
92+
model: { if (buddies[buddylist.currentIndex])
93+
buddies[buddylist.currentIndex].msgs
94+
}
95+
delegate: Text { text: modelData.text
96+
horizontalAlignment: { if (modelData.fromme)
8297
Text.AlignRight
8398
}
8499
width: parent.width
@@ -100,42 +115,18 @@ Rectangle {
100115
anchors.left: buddylist.right
101116
anchors.right: parent.right
102117
anchors.margins: 5
103-
enabled: false
104118

105119
onAccepted: { if (buddylist.length <= 0) return
106-
sendMsg(buddies.get(buddylist.currentIndex)["name"], msgentry.text)
107-
buddies.get(buddylist.currentIndex)["msgs"].append({ name: msgentry.text, fromme: true })
108-
msgarea.model = buddies.get(buddylist.currentIndex)["msgs"]
120+
sendMsg(buddies[buddylist.currentIndex], msgentry.text)
109121
msgentry.text = ""
110-
msgarea.positionViewAtEnd()
122+
msgarea.positionViewAtBeginning()
111123
}
112-
Rectangle {
113-
anchors.fill: parent
114-
border.width: 1; border.color: "darkgrey"
115-
radius: 5
116-
z: -5
117-
}
118-
}
119-
120-
Component.onCompleted: { self.msgReady.connect(msgReceived) }
121-
function msgReceived(msg) {
122124

123-
var buddyFound = false
124-
for (var i=0; i < buddies.count; i++) {
125-
if (buddies.get(i)["name"] == msg.buddy){
126-
buddies.get(i)["msgs"].append({ name: msg.text, fromme: false })
127-
msgarea.model = buddies.get(buddylist.currentIndex)["msgs"]
128-
buddyFound = true
129-
}
130-
}
131-
132-
if (buddyFound == false) {
133-
buddies.append({ "name": msg.buddy, "msgs": [ { name: msg.text, fromme: false } ] })
134-
/* TODO: Focus the buddy. This will make the next call work. */
135-
msgarea.model = buddies.get(buddylist.currentIndex)["msgs"]
136-
msgentry.enabled = true
125+
Rectangle {
126+
anchors.fill: parent
127+
border.width: 1; border.color: "darkgrey"
128+
radius: 5
129+
z: -5
137130
}
138-
139-
msgarea.positionViewAtEnd()
140131
}
141132
}

‎src/HSTorChat/GUI.hs‎

Lines changed: 44 additions & 40 deletions
Original file line numberDiff line numberDiff line change
@@ -18,58 +18,65 @@ import HSTorChat.Protocol
1818
data UI = UI
1919
{ _myonion :: Onion
2020
, _mystatus :: BuddyStatus
21-
, _buddies :: MVar [Buddy]
21+
, _buddies :: MVar [ObjRef Buddy]
2222
, _pending :: MVar [PendingConnection]
2323
} deriving Typeable
2424

2525
-- Signals
2626
data ChatMsgReady deriving Typeable
27+
data BuddiesChanged deriving Typeable
2728

2829
instance DefaultClass UI where
2930
classMembers = [
31+
defPropertySigRO "buddies" (Proxy :: Proxy BuddiesChanged)
32+
(readMVar . _buddies . fromObjRef :: ObjRef UI -> IO [ObjRef Buddy])
3033
-- | Return Onion address for this instance of HSTorChat.
31-
defMethod "onion" (return . _myonion . fromObjRef :: ObjRef UI -> IO Onion)
34+
, defMethod "onion" (return . _myonion . fromObjRef :: ObjRef UI -> IO Onion)
3235
-- | Send a message to a buddy.
3336
, defMethod "sendMsg" sendMsg
3437
-- | Add a new buddy.
3538
, defMethod "newBuddy" newBuddy
36-
-- | Access the context object (ObjRef UI) in qml callbacks.
37-
, defPropertyRO "self" (return :: ObjRef UI -> IO (ObjRef UI))
38-
-- | Called when a new message arrives from a buddy.
39-
, defSignal "msgReady" (Proxy :: Proxy ChatMsgReady)
4039
]
4140

4241
instance DefaultClass ChatMsg where
4342
classMembers = [
4443
defPropertyRO "buddy" (return . T.pack . buddy . fromObjRef)
4544
, defPropertyRO "text" (return . T.pack . text . fromObjRef)
45+
, defPropertyRO "fromme" (return . fromme . fromObjRef)
46+
]
47+
48+
instance DefaultClass Buddy where
49+
classMembers = [
50+
defPropertyRO "onion" (return . T.pack . _onion . fromObjRef)
51+
, defPropertyRO "status" (return . T.pack . show . _status . fromObjRef)
52+
, defPropertySigRO "msgs" (Proxy :: Proxy ChatMsgReady)
53+
(readMVar . _msgs . fromObjRef :: ObjRef Buddy -> IO [ObjRef ChatMsg])
4654
]
4755

4856
instance Marshal ChatMsg where
4957
type MarshalMode ChatMsg c d = ModeObjFrom ChatMsg c
5058
marshaller = fromMarshaller fromObjRef
5159

60+
instance Marshal Buddy where
61+
type MarshalMode Buddy c d = ModeObjFrom Buddy c
62+
marshaller = fromMarshaller fromObjRef
63+
5264
instance SignalKeyClass ChatMsgReady where
53-
type SignalParams ChatMsgReady = ObjRef ChatMsg -> IO ()
65+
type SignalParams ChatMsgReady = IO ()
66+
67+
instance SignalKeyClass BuddiesChanged where
68+
type SignalParams BuddiesChanged = IO ()
5469

5570
-- | This method is called when the user enters
5671
-- a msg in a chat window. The handle for the buddy
5772
-- is accessed and used to send the message.
58-
--
59-
-- TODO: Pass Buddy instead of Text -> Text
60-
sendMsg :: ObjRef UI -> T.Text -> T.Text -> IO ()
61-
sendMsg ui onion msg = do
62-
let ui' = fromObjRef ui
63-
buds <- readMVar $ _buddies ui'
64-
sendMsgTo buds
73+
sendMsg :: ObjRef UI -> ObjRef Buddy -> T.Text -> IO ()
74+
sendMsg _ bud msg = do saveMsg $ ChatMsg (T.unpack msg) (_onion $ fromObjRef bud) True
75+
fireSignal (Proxy :: Proxy ChatMsgReady) bud
76+
hPutStrLn (_outConn $ fromObjRef bud) $ formatMsg $ Message msg
6577
where
66-
sendMsgTo [] = putStrLn "Unable to send message. No buddies."
67-
sendMsgTo buds = do
68-
-- Filter proper buddy from list.
69-
let thebuddy = head $ filter (\b -> _onion b == T.unpack onion) buds
70-
71-
-- | TODO: Reschedule if send is not succesful.
72-
hPutStrLn (_outConn thebuddy) $ formatMsg $ Message msg
78+
saveMsg cmsg = modifyMVar_ (_msgs $ fromObjRef bud) (\ms -> do m <- newObjectDC cmsg
79+
return (m:ms))
7380

7481
newBuddy :: ObjRef UI -> T.Text -> IO ()
7582
newBuddy ui onion = do
@@ -110,7 +117,7 @@ handleRequest ui iHdl = do
110117
b' <- readMVar (_buddies ui')
111118
-- Send Ping if this Buddy is new or Offline.
112119
when ((not $ any ((== key) . _pcookie) p') &&
113-
(not $ any ((/= Offline) . _status) b')
120+
(not $ any ((/= Offline) . _status) (map fromObjRef b'))
114121
) $ hPutStrLn oHdl $ formatMsg $ Ping (_myonion ui') cky
115122

116123
mapM_ (hPutStrLn oHdl . formatMsg) [ Pong key
@@ -140,25 +147,22 @@ handleRequest ui iHdl = do
140147
-- | A pending connection exists. Verify and start the buddy
141148
pendingConnection (PendingConnection cke o oHdl:pcs) = do
142149

143-
let b = Buddy (T.unpack o) iHdl oHdl cke Available
144-
ui' = fromObjRef ui
150+
ms <- newMVar []
151+
b <- newObjectDC $ Buddy (T.unpack o) iHdl oHdl cke Available ms
152+
let ui' = fromObjRef ui
145153

146154
modifyMVar_ (_buddies ui') (\bs -> return (b:bs))
147-
-- effectively, remove this pending connection from
148-
-- _pending.
149-
modifyMVar_ (_pending ui') (\_ -> return pcs)
150-
151-
-- A new Buddy has been identified.
152-
m <- newObjectDC $ ChatMsg ("A connection to " ++ T.unpack o ++ " has been established.") $ T.unpack o
153-
154-
-- TODO: Emit the `ProtocolMsg Message` constructor directly.
155-
-- Remove the Msg class and modify MsgReady sig.
156-
fireSignal (Proxy :: Proxy ChatMsgReady) ui m
155+
fireSignal (Proxy :: Proxy BuddiesChanged) ui
157156

157+
-- remove the pending connection.
158+
modifyMVar_ (_pending ui') (\_ -> return pcs)
158159
runBuddy ui b
159160

160-
runBuddy :: ObjRef UI -> Buddy -> IO ()
161-
runBuddy ui (Buddy onion iHdl oHdl cky st) = do
161+
runBuddy :: ObjRef UI -> ObjRef Buddy -> IO ()
162+
runBuddy ui objb = do
163+
let b = fromObjRef objb
164+
iHdl = _inConn b
165+
oHdl = _outConn b
162166

163167
txt <- hGetLine iHdl
164168
rdy <- hReady oHdl
@@ -176,12 +180,12 @@ runBuddy ui (Buddy onion iHdl oHdl cky st) = do
176180
, Status Available
177181
]
178182
Right (Message msg) -> do
179-
-- TODO: Emit the `ProtocolMsg Message` directly.
180-
m <- newObjectDC $ ChatMsg (T.unpack msg) onion
181-
fireSignal (Proxy :: Proxy ChatMsgReady) ui m
183+
cmsg <- newObjectDC $ ChatMsg (T.unpack msg) (_onion b) False
184+
modifyMVar_ (_msgs b) (\ms -> return (cmsg:ms))
185+
fireSignal (Proxy :: Proxy ChatMsgReady) objb
182186

183187
Right p -> print p
184188

185189
hFlush iHdl
186190
hFlush oHdl
187-
runBuddy ui $ Buddy onion iHdl oHdl cky st
191+
runBuddy ui objb

‎src/HSTorChat/Protocol.hs‎

Lines changed: 9 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -3,12 +3,14 @@
33
module HSTorChat.Protocol where
44

55
import Control.Applicative
6+
import Control.Concurrent
67
import Control.Monad
78
import Data.Attoparsec.Text
89
import qualified Data.Char as C
910
import qualified Data.Text as T
1011
import Data.Typeable
1112
import Data.Word
13+
import Graphics.QML
1214
import Prelude hiding (take)
1315
import qualified Prelude as P
1416
import Network
@@ -36,7 +38,7 @@ hstorchatHost = "127.0.0.1"
3638
hstorchatOutConn :: Onion -> IO Handle
3739
hstorchatOutConn onion = do
3840
outsock <- socksConnectWith (defaultSocksConf "127.0.0.1" 22209) (T.unpack onion) (PortNumber 11009)
39-
oHdl <- socketToHandle outsock ReadWriteMode
41+
oHdl <- socketToHandle outsock ReadWriteMode
4042
hSetBuffering oHdl LineBuffering
4143
return oHdl
4244

@@ -54,7 +56,8 @@ data Buddy = Buddy
5456
, _outConn :: Handle
5557
, _cookie :: Cookie -- ^ Cookie sent to buddy.
5658
, _status :: BuddyStatus -- * Buddy status
57-
} deriving (Show, Typeable)
59+
, _msgs :: MVar [ObjRef ChatMsg]
60+
} deriving (Typeable)
5861

5962
data BuddyStatus = Offline
6063
| Handshake
@@ -90,9 +93,10 @@ data ProtocolMsg = Ping Onion Cookie
9093
deriving Show
9194

9295
data ChatMsg = ChatMsg
93-
{ text :: String
94-
, buddy :: String
95-
} deriving Typeable
96+
{ text :: String
97+
, buddy :: String
98+
, fromme :: Bool
99+
} deriving (Show, Typeable)
96100

97101
parseResponse :: Parser ProtocolMsg
98102
parseResponse = try parsePingPong

0 commit comments

Comments
 (0)