OutGoing hooks so SessionView is updated etc

1 files changed, 108 insertions, 6 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 1821cb1c..8e34d4fe 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -62,7 +62,9 @@ import qualified Data.HashMap.Strict as HashMap
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import System.Posix.Signals
-
+import qualified Data.Array
+import qualified Data.Array.Unboxed as U
+import qualified Data.Conduit as Conduit
 
 import Announcer
 import Announcer.Tox
@@ -103,6 +105,13 @@ import OnionRouter
 import PingMachine
 import Data.PacketQueue
 import qualified Data.Word64Map as W64
+import System.FilePath
+import System.Process
+import System.Posix.IO
+import Data.Word64RangeMap
+import Network.Tox.Crypto.Transport
+import Data.Conduit.Cereal
+import qualified Data.Conduit.Binary as Conduit
 
 -- Presence imports.
 import ConsoleWriter
@@ -932,7 +941,9 @@ clientSession s@Session{..} sock cnum h = do
 
         -- necrypto <FRIEND-TOXID>
         -- establish a netcrypto session with specified person
-        ("netcrypto", s) -> cmd0 $ netcrypto (Map.lookup netname dhts) selectedKey h roster mbTox (strp s)
+        ("netcrypto", s) -> cmd0 $ do
+            let exes = Map.fromList [("atox",("/usr/bin/tmux -c","atox"))]
+            netcrypto (Map.lookup netname dhts) selectedKey h roster mbTox exes (strp s)
         ("g", s) | Just DHT{..} <- Map.lookup netname dhts
                     -> cmd0 $ do
                         -- arguments: method
@@ -1282,11 +1293,12 @@ netcrypto
   -> ClientHandle
   -> ContactInfo extra1
   -> Maybe (Tox.Tox extra2)
+  -> Map.Map String (String,String) -- profile name to (multiplexer,exe name) for supported child executables
   -> String
   -> IO ()
-netcrypto _ _ h _ Nothing _ =  hPutClient h "Requires Tox enabled."
-netcrypto _ Nothing h _ _ _ =  hPutClient h "No key is selected, see k command."
-netcrypto (Just (DHT {..})) (Just mypubkey) h roster (Just tox) keystr =
+netcrypto _ _ h _ Nothing _ _ =  hPutClient h "Requires Tox enabled."
+netcrypto _ Nothing h _ _ _ _ =  hPutClient h "No key is selected, see k command."
+netcrypto (Just (DHT {..})) (Just mypubkey) h roster (Just tox) exes paramStr =
     either
       (const $
        either
@@ -1297,6 +1309,25 @@ netcrypto (Just (DHT {..})) (Just mypubkey) h roster (Just tox) keystr =
       (goPubkey . Tox.id2key) $
     readEither keystr -- attempt read as NodeId type
   where
+    params = words paramStr
+    keystr = bool (head params) "" (null params)
+    -- TODO:
+    -- execProfiles:
+    -- atox@24-25,48-51,64-45  gnome-tox-notifier@24-25,49,50
+    --      ^-- word64 type values that should be forwarded to this process
+    execParams=drop 1 params
+    parseExecParam :: String -> (String,[(Maybe Word64,Maybe Word64)])
+    parseExecParam param = let (name,drop 1 -> rangesCombined) = span (/='@') param
+                               wordsBy x str = groupBy (const (/=x)) str
+                               rangesUnparsed = wordsBy ',' rangesCombined
+                               parseRange :: String -> (Maybe Word64,Maybe Word64)
+                               parseRange "all" = (Nothing,Nothing)
+                               parseRange x = let (low,drop 1 -> high) = break (==',') x
+                                                  in (readMaybe low,readMaybe high)
+                               in (name,map parseRange rangesUnparsed)
+    execs = map parseExecParam execParams
+
+
     goNodeInfo userkey_nodeinfo = do
       msec <-
         atomically $ do
@@ -1314,7 +1345,78 @@ netcrypto (Just (DHT {..})) (Just mypubkey) h roster (Just tox) keystr =
             Just account -> do
               now <- getPOSIXTime
               atomically $ setContactAddr now their_pub their_addr account
-              Tox.netCrypto tox sec their_pub
+              sessions <- Tox.netCrypto tox sec their_pub
+              exeDir <- takeDirectory <$> getExecutablePath
+              forM_ sessions $ \session -> do
+                forM_ execs $ \(exekey,ranges) -> do
+                    case Map.lookup exekey exes of
+                        Nothing -> return ()
+                        Just (multiplexer,exename) -> do
+                            let exepath = exeDir </> exename
+                            (myReadFd,myWriteFd) <- System.Posix.IO.createPipe
+                            myRead  <- fdToHandle myReadFd
+                            myWrite <- fdToHandle myWriteFd
+                            whoAmI <- atomically $ newTVar mypubkey
+                            whoAreThey <- atomically $ newTVar their_pub
+                            let fdArgs = [show myWriteFd,show myReadFd]
+                            if null multiplexer
+                                then callProcess exepath fdArgs
+                                else do
+                                    let (multiplexer_exe,multiplexer_args) = splitAt 1 (words multiplexer)
+                                    callProcess multiplexer (multiplexer_args ++ [intercalate " " (exepath:fdArgs)])
+                            -- tell subprocess who is talking to who
+                            B.hPutStr myWrite ("\NUL\NUL" `B.append` S.encode (Tox.key2id mypubkey))
+                            B.hPutStr myWrite ("\NUL\SOH" `B.append` S.encode (Tox.key2id their_pub))
+                            -- add hooks so subprocess is updated on incoming
+                            let makeHook session typ
+                                    = \session msg
+                                       -> do -- if (getMessageType msg == typ)
+                                             me <- atomically $ readTVar whoAmI
+                                             when (me /= mypubkey) $ do
+                                                atomically $ writeTVar whoAmI mypubkey
+                                                B.hPutStr myWrite ("\NUL\NUL" `B.append` S.encode (Tox.key2id mypubkey))
+                                             them <- atomically $ readTVar whoAreThey
+                                             when (them /= their_pub) $ do
+                                                atomically $ writeTVar whoAreThey their_pub
+                                                B.hPutStr myWrite ("\NUL\SOH" `B.append` S.encode (Tox.key2id their_pub))
+                                             B.hPutStr myWrite (S.encode msg)
+                                             return (Just id)
+                                addHooks currentHooks typs = forM_ typs $ \typ -> modifyTVar (Tox.ncHooks session) (Map.insert typ (currentHooks typ ++ [makeHook session typ]))
+                            case ranges of
+                                [(Nothing,Nothing)] -> atomically $ do
+                                     typs <- map fromWord64 . filter (/=0) . U.elems <$> readTVar (Tox.ncIncomingTypeArray session)
+                                     addHooks (const []) typs
+                                _ -> atomically . forM_ ranges $ \range -> do
+                                    case range of
+                                        (Just first,Just last) -> do
+                                            let typs = map fromWord64 [first .. last]
+                                            hooks <- readTVar (Tox.ncHooks session)
+                                            let currentHooks typ = fromMaybe [] (Map.lookup typ hooks)
+                                            addHooks currentHooks typs
+                            -- forward messages from subprocess
+                            forwardThread <- forkIO $ do
+                                tid <- myThreadId
+                                let sidStr = printf "(%x)" (Tox.ncSessionId session)
+                                labelThread tid (exekey ++ ".forward" ++ sidStr)
+                                let myconduit = Conduit.sourceHandle myRead  .| conduitGet2 S.get -- :: ConduitT i CryptoMessage IO ()
+                                Conduit.runConduit (myconduit .| awaitForever (\msg -> do
+                                    let typ = toWord64 (getMessageType msg)
+                                    mbSendIt <- liftIO $ atomically (lookupInRangeMap typ (Tox.ncOutHooks session))
+                                    case mbSendIt of
+                                        Just sendit -> liftIO . void $ sendit (Tox.toxCryptoKeys tox) session msg
+                                        Nothing     -> return () -- do
+                                         -- uncomment to let unhooked pass thru:
+                                         -- if lossyness (msgId msg) == Lossless
+                                         --             then sendLossless (Tox.toxCryptoKeys tox) session msg
+                                         --             else sendLossy (Tox.toxCryptoKeys tox) session msg
+                                    ))
+                            -- add hook to killThread on kill packet
+                            atomically $ do
+                                hooks <- readTVar (Tox.ncHooks session)
+                                let currentHooks = fromMaybe [] $ Map.lookup (Msg KillPacket) hooks
+                                let myhook :: Tox.NetCryptoSession  -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage))
+                                    myhook _ _ = killThread forwardThread >> return (Just id)
+                                modifyTVar' (Tox.ncHooks session) (Map.insert (Msg KillPacket) (currentHooks ++ [myhook]))
               hPutClient h "Handshake sent"
     goPubkey their_pub = do
       msec <-