2 files changed, 103 insertions, 0 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index ce1e1b16..291d0530 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -35,6 +35,7 @@ import Data.Function
 import Data.Hashable
 import Data.List
 import Data.Word
+import Data.InOrOut
 import qualified Data.IntMap.Strict as IntMap
 import qualified Data.Map.Strict as Map
 import Data.Maybe
@@ -122,10 +123,15 @@ showColumns rows = do
     _ <- take 1 fs -- Guard against empty rows so that 'last' is safe.
     "  " ++ concat (zipWith (printf "%-*s") (init ws) (init fs)) ++ last fs ++ "\n"
 
+pshow :: Show a => a -> B.ByteString
+pshow = B.pack . show
 
 marshalForClient :: String -> String
 marshalForClient s = show (length s) ++ ":" ++ s
 
+marshalForClientB :: B.ByteString -> B.ByteString
+marshalForClientB s = B.concat [pshow (B.length s),":",s]
+
 data ClientHandle = ClientHandle Handle (MVar Int)
 
 -- | Writes a message and signals ready for next command.
@@ -135,6 +141,13 @@ hPutClient (ClientHandle h hstate) s = do
     hPutStr h ('.' : marshalForClient s)
     putMVar hstate 1 -- ready for input
 
+-- | Writes a message and signals ready for next command.
+hPutClientB :: ClientHandle -> B.ByteString -> IO ()
+hPutClientB (ClientHandle h hstate) s = do
+    st <- takeMVar hstate
+    B.hPutStr h ('.' `B.cons` marshalForClientB s)
+    putMVar hstate 1 -- ready for input
+
 -- | Writes message, but signals there is more to come.
 hPutClientChunk :: ClientHandle -> String -> IO ()
 hPutClientChunk (ClientHandle h hstate) s = do
@@ -730,6 +743,41 @@ clientSession s@Session{..} sock cnum h = do
                  else do
                     rows <- sessionsReport
                     hPutClient h (showColumns (headers:rows))
+        -- session <N> tail
+        -- show context (latest lossless messages)
+        ("session", s) | (idStr,tailcmd,unstripped) <- twoWords s
+                        , "" <- strp unstripped
+                        , tailcmd `elem` ["tail","context"]
+                        -> cmd0 $ do
+                            lrSession <- strToSession idStr
+                            case lrSession of
+                                Left s -> hPutClient h s
+                                Right session -> do
+                                     msgs <- atomically $ CB.cyclicBufferViewList (Tox.ncLastNMsgs session)
+                                     hPutClientB h (B.unlines (map showMsg msgs))
+        -- session <N> me
+        -- display information about how you look to that session
+        ("session", s) | (idStr,"me",unstripped) <- twoWords s
+                        , "" <- strp unstripped
+                        -> cmd0 $ do
+                            lrSession <- strToSession idStr
+                            case lrSession of
+                                Left s -> hPutClient h s
+                                Right session -> do
+                                     view <- atomically (readTVar (Tox.ncView session) >>= Tox.viewSnapshot)
+                                     hPutClientB h (vShowMe view 0)
+        -- session <N> them
+        -- display information about the person on the other end of the session
+        ("session", s) | (idStr,them,unstripped) <- twoWords s
+                        , "" <- strp unstripped
+                        , them `elem` ["them","you"]
+                        -> cmd0 $ do
+                            lrSession <- strToSession idStr
+                            case lrSession of
+                                Left s -> hPutClient h s
+                                Right session -> do
+                                     view <- atomically (readTVar (Tox.ncView session) >>= Tox.viewSnapshot)
+                                     hPutClientB h (vShowThem view 0)
         -- session <N> online
         -- send ONLINE packet to session N
         ("session", s) | (idStr,"online",unstripped) <- twoWords s
@@ -833,6 +881,20 @@ clientSession s@Session{..} sock cnum h = do
                                         Just tox-> do
                                             Tox.setStatusMsg (Tox.toxCryptoKeys tox) session (B.pack statusmsg)
                                             hPutClient h "sent STATUSMESSAGE"
+        -- session <N> c <MSG>
+        -- send MESSAGE packet to session N (send chat message MSG)
+        ("session", s) | (idStr,msgcmd,msg) <- twoWords s
+                        , msgcmd `elem` ["c","msg","send"]
+                        -> cmd0 $ do
+                            lrSession <- strToSession idStr
+                            case lrSession of
+                                Left s -> hPutClient h s
+                                Right session -> do
+                                    case mbTox of
+                                        Nothing -> hPutClient h "Requires Tox enabled."
+                                        Just tox-> do
+                                            Tox.sendChatMsg (Tox.toxCryptoKeys tox) session (B.pack msg)
+                                            hPutClient h "sent MESSAGE"
 
         ("onion", s) -> cmd0 $ join $ atomically $ do
             rm <- readTVar $ routeMap onionRouter
@@ -1432,6 +1494,34 @@ announceToxJabberPeer echan laddr saddr pingflag tsrc tsnk
 
 #endif
 
+vShowMe :: Tox.ViewSnapshot -> Int -> B.ByteString
+vShowMe (Tox.ViewSnapshot { vNick, vStatus, vStatusMsg, vTyping }) indent
+    = B.unlines
+    . map doRow $  [ ["Nick: ", vNick ]
+                   , ["Status: ", "(" <> pshow vStatus <> ") " <> vStatusMsg ]
+                   , ["Typing: ", pshow vTyping ]
+                   ]
+    where (<>) = B.append
+          space = B.replicate indent ' '
+          doRow = B.append space . B.concat
+
+vShowThem :: Tox.ViewSnapshot -> Int -> B.ByteString
+vShowThem (Tox.ViewSnapshot { vTheirNick, vTheirStatus, vTheirStatusMsg, vTheirTyping }) indent
+    = B.unlines
+    . map doRow $  [ ["Nick: ", vTheirNick ]
+                   , ["Status: ", "(" <> pshow vTheirStatus <> ") " <> vTheirStatusMsg ]
+                   , ["Typing: ", pshow vTheirTyping ]
+                   ]
+    where (<>) = B.append
+          space = B.replicate indent ' '
+          doRow = B.append space . B.concat
+
+showMsg ::(Word32, (Bool,(Tox.ViewSnapshot, InOrOut Tox.CryptoMessage))) -> B.ByteString
+showMsg (n,(flg,(snapshot,iocm))) = B.concat [bool "  " "h " flg, showmsg' (snapshot,iocm)]
+    where
+        showmsg' (snapshot,In cm) = B.concat [Tox.vNick snapshot,"> ", pshow cm]
+        showmsg' (snapshot,Out cm) = B.concat [utf8boldify (Tox.vNick snapshot),": ",pshow cm]
+        utf8boldify s = s
 
 main :: IO ()
 main = runResourceT $ liftBaseWith $ \resT -> do
diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
index 92cb19b8..2902685c 100644
--- a/src/Network/Tox/Crypto/Handlers.hs
+++ b/src/Network/Tox/Crypto/Handlers.hs
@@ -806,6 +806,19 @@ setStatusMsg crypto session msg = do
         addMsgToLastN False (cm ^. messageType) session (Out cm)
         sendCrypto crypto session updateLocal cm
 
+sendChatMsg :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String ())
+sendChatMsg crypto session msg = do
+    let Just (_,maxlen) = msgSizeParam MESSAGE
+    if B.length msg > maxlen
+     then return (Left $ "status message must not exceed " ++ show maxlen ++ " bytes.")
+     else do
+        let updateLocal = do
+                view <- readTVar (ncView session)
+                writeTVar (svStatusMsg view) msg
+        let cm = UpToN MESSAGE msg
+        addMsgToLastN False (cm ^. messageType) session (Out cm)
+        sendCrypto crypto session updateLocal cm
+
 -- | handles nothings
 defaultCryptoDataHooks :: Map.Map MessageType [NetCryptoHook]
 defaultCryptoDataHooks