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
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
|
module Main (main) where
import Control.Concurrent
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Maybe
import Data.Char
import Data.List
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Time.Format
import Data.Time.LocalTime
import System.Console.Haskeline
import System.Environment
import System.IO
import Identity
import Message
import Network
import PubKey
import Storage
data Erebos = Erebos
{ erbIdentity :: Stored Identity
, erbMessages :: StoredList DirectMessageThread
}
instance Storable Erebos where
store' erb = storeRec $ do
storeRef "id" $ erbIdentity erb
storeZRef "dmsgs" $ erbMessages erb
load' = loadRec $ Erebos
<$> loadRef "id"
<*> loadZRef "dmsgs"
loadErebosHead :: Storage -> IO Head
loadErebosHead st = loadHeadDef st "erebos" $ do
putStr "Name: "
hFlush stdout
name <- T.getLine
(secret, public) <- generateKeys st
(_secretMsg, publicMsg) <- generateKeys st
(devSecret, devPublic) <- generateKeys st
(_devSecretMsg, devPublicMsg) <- generateKeys st
owner <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentity public publicMsg) { idName = Just name }
identity <- wrappedStore st =<< signAdd devSecret =<< sign secret =<<
wrappedStore st (emptyIdentity devPublic devPublicMsg) { idOwner = Just owner }
msgs <- emptySList st
return $ Erebos
{ erbIdentity = identity
, erbMessages = msgs
}
updateErebosHead_ :: Storage -> (Stored Erebos -> IO (Stored Erebos)) -> IO ()
updateErebosHead_ st f = updateErebosHead st (fmap (,()) . f)
updateErebosHead :: Storage -> (Stored Erebos -> IO (Stored Erebos, a)) -> IO a
updateErebosHead st f = do
Just erebosHead <- loadHead st "erebos"
(erebos, x) <- f $ wrappedLoad (headRef erebosHead)
Right _ <- replaceHead erebos (Right erebosHead)
return x
main :: IO ()
main = runInputT defaultSettings $ do
bhost <- liftIO getArgs >>= \case [bhost] -> return bhost
_ -> error "Expecting broadcast address"
st <- liftIO $ openStorage "test"
erebosHead <- liftIO $ loadErebosHead st
let serebos = wrappedLoad (headRef erebosHead) :: Stored Erebos
self = erbIdentity $ fromStored serebos
outputStrLn $ T.unpack $ displayIdentity self
haveTerminalUI >>= \case True -> return ()
False -> error "Requires terminal"
extPrint <- getExternalPrint
let extPrintLn str = extPrint $ str ++ "\n";
(chanPeer, chanSvc) <- liftIO $
startServer extPrintLn bhost $ erbIdentity $ fromStored serebos
peers <- liftIO $ newMVar []
void $ liftIO $ forkIO $ void $ forever $ do
peer@Peer { peerAddress = DatagramAddress addr } <- readChan chanPeer
extPrint $ show addr ++ "\n"
extPrintLn $ maybe "<noid>" (T.unpack . displayIdentity) $ peerIdentity peer
let update [] = [peer]
update (p:ps) | peerIdentity p == peerIdentity peer = peer : ps
| otherwise = p : update ps
when (isJust $ peerIdentity peer) $
modifyMVar_ peers (return . update)
tzone <- liftIO $ getCurrentTimeZone
void $ liftIO $ forkIO $ forever $ readChan chanSvc >>= \case
(peer, svc, ref)
| svc == T.pack "dmsg" -> do
let smsg = wrappedLoad ref
msg = fromStored smsg
extPrintLn $ formatMessage tzone msg
if | Just powner <- finalOwner <$> peerIdentity peer
, powner == msgFrom msg
-> updateErebosHead_ st $ \erb -> do
slist <- case find ((== powner) . msgPeer . fromStored) (storedFromSList $ erbMessages $ fromStored erb) of
Just thread -> do thread' <- wrappedStore st (fromStored thread) { msgHead = smsg : msgHead (fromStored thread) }
slistReplaceS thread thread' $ erbMessages $ fromStored erb
Nothing -> slistAdd (emptyDirectThread powner) { msgHead = [smsg] } $ erbMessages $ fromStored erb
wrappedStore st (fromStored erb) { erbMessages = slist }
| otherwise -> extPrint $ "Owner mismatch"
| otherwise -> extPrint $ "Unknown service: " ++ T.unpack svc
let process cstate = do
let pname = case csPeer cstate of
Nothing -> ""
Just peer -> maybe "<unnamed>" T.unpack $ idName . fromStored . signedData . fromStored . finalOwner <=< peerIdentity $ peer
Just input <- lift $ getInputLine $ pname ++ "> "
let (cmd, line) = case input of
'/':rest -> let (scmd, args) = dropWhile isSpace <$> span isAlphaNum rest
in if all isDigit scmd
then (cmdSetPeer $ read scmd, args)
else (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args)
_ -> (cmdSend, input)
liftIO $ flip execStateT cstate $ runReaderT cmd CommandInput
{ ciSelf = self
, ciLine = line
, ciPeers = liftIO $ readMVar peers
}
let loop (Just cstate) = runMaybeT (process cstate) >>= loop
loop Nothing = return ()
loop $ Just $ CommandState { csPeer = Nothing }
data CommandInput = CommandInput
{ ciSelf :: Stored Identity
, ciLine :: String
, ciPeers :: CommandM [Peer]
}
data CommandState = CommandState
{ csPeer :: Maybe Peer
}
type CommandM a = ReaderT CommandInput (StateT CommandState IO) a
type Command = CommandM ()
commands :: [(String, Command)]
commands =
[ ("history", cmdHistory)
, ("peers", cmdPeers)
, ("send", cmdSend)
]
cmdUnknown :: String -> Command
cmdUnknown cmd = liftIO $ putStrLn $ "Unknown command: " ++ cmd
cmdPeers :: Command
cmdPeers = do
peers <- join $ asks ciPeers
forM_ (zip [1..] peers) $ \(i :: Int, p) -> do
liftIO $ putStrLn $ show i ++ ": " ++ maybe "<noid>" (T.unpack . displayIdentity) (peerIdentity p)
cmdSetPeer :: Int -> Command
cmdSetPeer n | n < 1 = liftIO $ putStrLn "Invalid peer index"
| otherwise = do peers <- join $ asks ciPeers
modify $ \s -> s { csPeer = listToMaybe $ drop (n - 1) peers }
cmdSend :: Command
cmdSend = void $ runMaybeT $ do
self <- asks ciSelf
let st = storedStorage self
Just peer <- gets csPeer
Just powner <- return $ finalOwner <$> peerIdentity peer
_:_ <- return $ peerChannels peer
text <- asks ciLine
smsg <- liftIO $ updateErebosHead st $ \erb -> do
(slist, smsg) <- case find ((== powner) . msgPeer . fromStored) (storedFromSList $ erbMessages $ fromStored erb) of
Just thread -> do
(smsg, thread') <- createDirectMessage self (fromStored thread) (T.pack text)
(,smsg) <$> slistReplaceS thread thread' (erbMessages $ fromStored erb)
Nothing -> do
(smsg, thread') <- createDirectMessage self (emptyDirectThread powner) (T.pack text)
(,smsg) <$> slistAddS thread' (erbMessages $ fromStored erb)
erb' <- wrappedStore st (fromStored erb) { erbMessages = slist }
return (erb', smsg)
liftIO $ sendToPeer self peer (T.pack "dmsg") smsg
tzone <- liftIO $ getCurrentTimeZone
liftIO $ putStrLn $ formatMessage tzone $ fromStored smsg
cmdHistory :: Command
cmdHistory = void $ runMaybeT $ do
self <- asks ciSelf
let st = storedStorage self
Just peer <- gets csPeer
Just powner <- return $ finalOwner <$> peerIdentity peer
Just erebosHead <- liftIO $ loadHead st "erebos"
let erebos = wrappedLoad (headRef erebosHead)
Just thread <- return $ find ((==powner) . msgPeer) $ fromSList $ erbMessages $ fromStored erebos
tzone <- liftIO $ getCurrentTimeZone
liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 $ threadToList thread
formatMessage :: TimeZone -> DirectMessage -> String
formatMessage tzone msg = concat
[ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg
, maybe "<unnamed>" T.unpack $ idName $ fromStored $ signedData $ fromStored $ msgFrom msg
, ": "
, T.unpack $ msgText msg
]
|