summaryrefslogtreecommitdiff
path: root/src/Main.hs
blob: e6e9d9c53a59ecd0b5714a8fd05cafa9b017ad25 (plain)
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
    T.putStrLn $ displayIdentity self

    (chanPeer, chanSvc) <- startServer bhost $ erbIdentity $ fromStored serebos

    void $ forkIO $ void $ forever $ do
        peer@Peer { peerAddress = DatagramAddress addr } <- readChan chanPeer
        print addr
        T.putStrLn $ maybe (T.pack "<noid>") displayIdentity $ 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 ()