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
|
module Main (main) where
import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.List
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T
import System.Environment
import System.IO
import System.IO.Error
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 = do
catchJust (guard . isDoesNotExistError) (loadHead 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
let erebos = Erebos
{ erbIdentity = identity
, erbMessages = msgs
}
Right h <- replaceHead erebos (Left (st, "erebos"))
return h
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
erebosHead <- loadHead st "erebos"
(erebos, x) <- f $ wrappedLoad (headRef erebosHead)
Right _ <- replaceHead erebos (Right erebosHead)
return x
main :: IO ()
main = do
[bhost] <- getArgs
st <- openStorage "test"
erebosHead <- loadErebosHead st
let serebos = wrappedLoad (headRef erebosHead) :: Stored Erebos
self = erbIdentity $ fromStored serebos
print $ fromStored self
(chanPeer, chanSvc) <- startServer bhost $ erbIdentity $ fromStored serebos
void $ forkIO $ void $ forever $ do
peer@Peer { peerAddress = DatagramAddress addr } <- readChan chanPeer
print addr
putStrLn $ maybe "<noid>" show $ peerIdentity peer
if | Just powner <- finalOwner <$> peerIdentity peer
, _:_ <- peerChannels peer
-> do
msg <- updateErebosHead st $ \erb -> do
(slist, msg) <- case find ((== powner) . msgPeer . fromStored) (storedFromSList $ erbMessages $ fromStored erb) of
Just thread -> do
(msg, thread') <- createDirectMessage self (fromStored thread) (T.pack "Hello")
(,msg) <$> slistReplaceS thread thread' (erbMessages $ fromStored erb)
Nothing -> do
(msg, thread') <- createDirectMessage self (emptyDirectThread powner) (T.pack "Hello")
(,msg) <$> slistAddS thread' (erbMessages $ fromStored erb)
erb' <- wrappedStore st (fromStored erb) { erbMessages = slist }
return (erb', msg)
sendToPeer self peer (T.pack "dmsg") msg
| otherwise -> return ()
void $ forever $ readChan chanSvc >>= \case
(peer, svc, ref)
| svc == T.pack "dmsg" -> do
let msg = wrappedLoad ref
putStr "Direct message from: "
T.putStrLn $ fromMaybe (T.pack "<unnamed>") $ idName $ fromStored $ signedData $ fromStored $ msgFrom $ fromStored msg
if | Just powner <- finalOwner <$> peerIdentity peer
, powner == msgFrom (fromStored 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 = msg : msgHead (fromStored thread) }
slistReplaceS thread thread' $ erbMessages $ fromStored erb
Nothing -> slistAdd (emptyDirectThread powner) { msgHead = [msg] } $ erbMessages $ fromStored erb
wrappedStore st (fromStored erb) { erbMessages = slist }
| otherwise -> putStrLn $ "Owner mismatch"
| otherwise -> T.putStrLn $ T.pack "Unknown service: " `T.append` svc
return ()
|