Skip to content

Commit

Permalink
Model the buddy list and messages from QML.
Browse files Browse the repository at this point in the history 
No longer contain replicated state in QML.
  • Loading branch information
@creichert
creichert committed May 7, 2014
1 parent 933c45a commit f3175e9
Show file tree
Hide file tree
Showing 3 changed files with 85 additions and 86 deletions.
73 changes: 32 additions & 41 deletions qml/HSTorChat.qml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,10 +5,6 @@ Rectangle {
id: root
width: 500; height: 600

ListModel {
id: buddies
}

ListView {
id: buddylist
anchors.left: parent.left
Expand All @@ -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"
}
}
}

Expand Down Expand Up @@ -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
Expand All @@ -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()
}
}
84 changes: 44 additions & 40 deletions src/HSTorChat/GUI.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
14 changes: 9 additions & 5 deletions src/HSTorChat/Protocol.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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

Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down

0 comments on commit f3175e9

Please sign in to comment.