1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
|
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
import Control.Monad.IO.Class
import Control.Concurrent
import Control.Concurrent.STM
import qualified Data.ByteString.Char8 as B
import Data.ByteString (ByteString)
import Data.Char
import qualified Data.Conduit as Conduit
import Data.Conduit ((.|))
import qualified Data.Conduit.Binary as Conduit
import Data.Conduit.Cereal
import Data.Function
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import Data.Sequence (Seq(..),(|>))
import Data.Monoid
import qualified Data.Serialize as S
import Data.Serialize (Get(..), Put(..))
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8,decodeUtf8)
import Network.Tox.Crypto.Transport
import Network.Tox.Crypto.Handlers
import Network.Tox.NodeId
import System.Console.ANSI
import qualified System.Console.Terminal.Size as Term
import System.Environment
import System.Exit
import System.FilePath
import System.IO
import System.IO.Unsafe (unsafePerformIO)
import qualified System.Posix.Env.ByteString as B
import System.Posix.IO.ByteString
import System.Posix.Types
import Text.Read
data Key = Key NodeId{-me-} NodeId{-them-}
deriving (Eq,Ord)
-- Some Global State --
{-# NOINLINE sMe #-}
sMe :: TVar NodeId
sMe = unsafePerformIO $ newTVarIO zero
where Right zero = (S.decode $ B.replicate 32 '\NUL')
{-# NOINLINE sThem #-}
sThem :: TVar NodeId
sThem = unsafePerformIO $ newTVarIO zero
where Right zero = (S.decode $ B.replicate 32 '\NUL')
{-# NOINLINE sMap #-}
sMap :: TVar (Map.Map Key ViewSnapshot)
sMap = unsafePerformIO $ newTVarIO (Map.empty)
{-# NOINLINE sScroll #-}
sScroll :: TVar (Map.Map Key (Seq CryptoMessage))
sScroll = unsafePerformIO $ newTVarIO (Map.empty)
-----------------------
puts :: MonadIO m => ByteString -> m ()
puts = liftIO . B.putStrLn
packUtf8 :: String -> ByteString
packUtf8 = encodeUtf8 . T.pack
pshow :: Show a => a -> ByteString
pshow = packUtf8 . show
usage = do
hPutStrLn stderr "Usage: atox <INPUT-FILE-DESCRIPTOR> <OUTPUT-FILE-DESCRIPTOR>"
exitFailure
processArgs usage doit [readNum,writeNum] | Just i <- readMaybe readNum
, Just o <- readMaybe writeNum = doit i o
processArgs usage _ _ = usage
main = getArgs >>= processArgs usage doit
pattern IPC = Padding
-- | Interprocess command
data SetCmd = SetME
| SetTHEM
| SetView
| AppendMsg
deriving (Eq,Bounded,Ord,Enum,Show)
forkToxInputThread myRead = forkIO $ do
let myconduit = Conduit.sourceHandle myRead .| conduitGet2 (getCryptoMessage 0 :: Get CryptoMessage) -- :: ConduitT i CryptoMessage IO ()
Conduit.runConduit (myconduit .| Conduit.awaitForever handle)
where
handle (UpToN IPC (B.uncons -> Just (ord -> toEnum -> i,arg))) = updateState i arg
handle msg = puts (pshow msg)
updateState SetME arg = case S.decode arg of
Left str -> puts (packUtf8 str)
Right x -> liftIO . atomically . writeTVar sMe $ x
updateState SetTHEM arg = case S.decode arg of
Left str -> puts (packUtf8 str)
Right x -> liftIO . atomically . writeTVar sThem $ x
updateState SetView arg = case S.decode arg of
Left str -> puts (packUtf8 str)
Right view -> liftIO . atomically $ do
me <- readTVar sMe
them <- readTVar sThem
let key = Key me them
modifyTVar' sMap (Map.insert key view)
updateState AppendMsg arg
= case getCryptoMessage 0 `S.runGet` arg of
Left str -> puts (packUtf8 str)
Right msg -> liftIO . atomically $ do
me <- readTVar sMe
them <- readTVar sThem
let key = Key me them
scroll <- readTVar sScroll
let mbCurrentMsgs = Map.lookup key scroll
case mbCurrentMsgs of
Nothing -> modifyTVar' sScroll (Map.insert key (Seq.singleton msg))
Just history -> modifyTVar' sScroll (Map.insert key (history |> msg))
doit :: Fd -> Fd -> IO ()
doit myReadFd myWriteFd = do
myRead <- fdToHandle myReadFd
myWrite <- fdToHandle myWriteFd
forkToxInputThread myRead
terminalInputLoop myWrite
hSend :: MonadIO m => Handle -> CryptoMessage -> m ()
hSend h msg = liftIO $ B.hPutStrLn h (S.runPut $ putCryptoMessage 0 msg)
terminalInputLoop myWriteH = fix $ \loop -> do
line <- B.getLine
if "/" `B.isPrefixOf` line then let (B.drop 1 -> cmd, B.drop 1 -> arg) = B.break (==' ') line
in slashCommand myWriteH (B.drop 1 line) arg
else hSend myWriteH (UpToN MESSAGE line)
loop
slashCommand :: MonadIO m => Handle -> ByteString -> ByteString -> m ()
slashCommand h "quit" _ = do
hSend h (OneByte OFFLINE)
hSend h (OneByte KillPacket)
puts "Exiting..."
liftIO $ exitSuccess
slashCommand h "nick" (B.words -> take 1 -> [nick]) = hSend h (UpToN NICKNAME nick)
slashCommand h "away" msg = do
hSend h (TwoByte USERSTATUS (fromEnum8 Away))
hSend h (UpToN STATUSMESSAGE msg)
slashCommand h "back" msg = do
hSend h (TwoByte USERSTATUS (fromEnum8 Online))
hSend h (UpToN STATUSMESSAGE msg)
slashCommand h cmd _ = do
puts $ "UNKNOWN COMMAND: " <> cmd
|
