summaryrefslogtreecommitdiff
path: root/src/Network.hs
blob: eb72ed27c25ecbe7bfa0d5d6ecc6d45de747369f (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
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
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
module Network (
    Peer(..),
    PeerAddress(..),
    startServer,
    sendToPeer,
) where

import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Except

import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M
import qualified Data.Text as T

import Network.Socket
import Network.Socket.ByteString (recvFrom, sendTo)

import Channel
import Identity
import PubKey
import Storage


discoveryPort :: ServiceName
discoveryPort = "29665"


data Peer = Peer
    { peerAddress :: PeerAddress
    , peerIdentity :: Maybe (Stored Identity)
    , peerChannels :: [Channel]
    , peerSocket :: Socket
    , peerStorage :: Storage
    , peerInStorage :: PartialStorage
    }
    deriving (Show)

data PeerAddress = DatagramAddress SockAddr
    deriving (Show)


data TransportHeader = AnnouncePacket PartialRef
                     | IdentityRequest PartialRef PartialRef
                     | IdentityResponse PartialRef
                     | TrChannelRequest PartialRef
                     | TrChannelAccept PartialRef

data ServiceHeader = ServiceHeader T.Text PartialRef

transportToObject :: TransportHeader -> PartialObject
transportToObject = \case
    AnnouncePacket ref -> Rec
        [ (BC.pack "TRANS", RecText $ T.pack "announce")
        , (BC.pack "identity", RecRef ref)
        ]
    IdentityRequest ref from -> Rec
        [ (BC.pack "TRANS", RecText $ T.pack "idreq")
        , (BC.pack "identity", RecRef ref)
        , (BC.pack "from", RecRef from)
        ]
    IdentityResponse ref -> Rec
        [ (BC.pack "TRANS", RecText $ T.pack "idresp")
        , (BC.pack "identity", RecRef ref)
        ]
    TrChannelRequest ref -> Rec
        [ (BC.pack "TRANS", RecText $ T.pack "chreq")
        , (BC.pack "req", RecRef ref)
        ]
    TrChannelAccept ref -> Rec
        [ (BC.pack "TRANS", RecText $ T.pack "chacc")
        , (BC.pack "acc", RecRef ref)
        ]

transportFromObject :: PartialObject -> Maybe TransportHeader
transportFromObject (Rec items)
    | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "announce"
    , Just (RecRef ref) <- lookup (BC.pack "identity") items
    = Just $ AnnouncePacket ref

    | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "idreq"
    , Just (RecRef ref) <- lookup (BC.pack "identity") items
    , Just (RecRef from) <- lookup (BC.pack "from") items
    = Just $ IdentityRequest ref from

    | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "idresp"
    , Just (RecRef ref) <- lookup (BC.pack "identity") items
    = Just $ IdentityResponse ref

    | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "chreq"
    , Just (RecRef ref) <- lookup (BC.pack "req") items
    = Just $ TrChannelRequest ref

    | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "chacc"
    , Just (RecRef ref) <- lookup (BC.pack "acc") items
    = Just $ TrChannelAccept ref

transportFromObject _ = Nothing

serviceToObject :: ServiceHeader -> PartialObject
serviceToObject (ServiceHeader svc ref) = Rec
        [ (BC.pack "SVC", RecText svc)
        , (BC.pack "ref", RecRef ref)
        ]

serviceFromObject :: PartialObject -> Maybe ServiceHeader
serviceFromObject (Rec items)
    | Just (RecText svc) <- lookup (BC.pack "SVC") items
    , Just (RecRef ref) <- lookup (BC.pack "ref") items
    = Just $ ServiceHeader svc ref
serviceFromObject _ = Nothing


startServer :: (String -> IO ()) -> String -> Stored Identity -> IO (Chan Peer, Chan (Peer, T.Text, Ref))
startServer logd bhost sidentity = do
    chanPeer <- newChan
    chanSvc <- newChan
    peers <- newMVar M.empty

    let open addr = do
            sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
            setSocketOption sock ReuseAddr 1
            setSocketOption sock Broadcast 1
            setCloseOnExecIfNeeded =<< fdSocket sock
            bind sock (addrAddress addr)
            return sock

        loop sock = do
            st <- derivePartialStorage $ storedStorage sidentity
            baddr:_ <- getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just bhost) (Just discoveryPort)
            void $ sendTo sock (BL.toStrict $ serializeObject $ transportToObject $ AnnouncePacket $ partialRef st $ storedRef sidentity) (addrAddress baddr)
            forever $ do
                (msg, paddr) <- recvFrom sock 4096
                mbpeer <- M.lookup paddr <$> readMVar peers
                if | Just peer <- mbpeer
                   , ch:_ <- peerChannels peer
                   , Just plain <- channelDecrypt ch msg
                   , Right (obj:objs) <- runExcept $ deserializeObjects (peerInStorage peer) $ BL.fromStrict plain
                   , Just (ServiceHeader svc ref) <- serviceFromObject obj
                   -> do forM_ objs $ storeObject $ peerInStorage peer
                         copyRef (peerStorage peer) ref >>= \case
                             Just pref -> writeChan chanSvc (peer, svc, pref)
                             Nothing   -> logd $ show paddr ++ ": incomplete service packet"

                   | otherwise -> do
                       (pst, ist) <- case mbpeer of
                                          Just peer -> return (peerStorage peer, peerInStorage peer)
                                          Nothing   -> do pst <- deriveEphemeralStorage $ storedStorage sidentity
                                                          ist <- derivePartialStorage pst
                                                          return (pst, ist)
                       if | Right (obj:objs) <- runExcept $ deserializeObjects ist $ BL.fromStrict msg
                          , Just tpack <- transportFromObject obj
                          -> packet sock paddr tpack objs pst ist

                          | otherwise -> logd $ show paddr ++ ": invalid packet"

        packet sock paddr (AnnouncePacket ref) _ _ ist = do
            logd $ "Got announce: " ++ show ref ++ " from " ++ show paddr
            when (refDigest ref /= refDigest (storedRef sidentity)) $ void $ sendTo sock (BL.toStrict $ BL.concat
                [ serializeObject $ transportToObject $ IdentityRequest ref (partialRef ist $ storedRef sidentity)
                , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
                ]) paddr

        packet _ paddr (IdentityRequest ref from) [] _ _ = do
            logd $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr ++ " without content"

        packet sock paddr (IdentityRequest ref from) (obj:objs) pst ist = do
            logd $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr
            logd $ show (obj:objs)
            from' <- storeObject ist obj
            if from == from'
               then do forM_ objs $ storeObject ist
                       copyRef pst from >>= \case
                           Nothing -> logd $ "Incomplete peer identity"
                           Just sfrom -> do
                               let peer = Peer (DatagramAddress paddr) (Just $ wrappedLoad sfrom) [] sock pst ist
                               modifyMVar_ peers $ return . M.insert paddr peer
                               writeChan chanPeer peer
                               void $ sendTo sock (BL.toStrict $ BL.concat
                                   [ serializeObject $ transportToObject $ IdentityResponse (partialRef ist $ storedRef sidentity)
                                   , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
                                   ]) paddr
               else logd $ "Mismatched content"

        packet _ paddr (IdentityResponse ref) [] _ _ = do
            logd $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr ++ " without content"

        packet sock paddr (IdentityResponse ref) (obj:objs) pst ist = do
            logd $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr
            logd $ show (obj:objs)
            ref' <- storeObject ist obj
            if ref == ref'
               then do forM_ objs $ storeObject ist
                       copyRef pst ref >>= \case
                           Nothing -> logd $ "Incomplete peer identity"
                           Just sref -> do
                               let pidentity = wrappedLoad sref
                                   peer = Peer (DatagramAddress paddr) (Just pidentity) [] sock pst ist
                               modifyMVar_ peers $ return . M.insert paddr peer
                               writeChan chanPeer peer
                               req <- createChannelRequest pst sidentity pidentity
                               void $ sendTo sock (BL.toStrict $ BL.concat
                                   [ serializeObject $ transportToObject $ TrChannelRequest (partialRef ist $ storedRef req)
                                   , lazyLoadBytes $ storedRef req
                                   , lazyLoadBytes $ storedRef $ signedData $ fromStored req
                                   , lazyLoadBytes $ storedRef $ crKey $ fromStored $ signedData $ fromStored req
                                   , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored req
                                   ]) paddr
               else logd $ "Mismatched content"

        packet _ paddr (TrChannelRequest _) [] _ _ = do
            logd $ "Got channel request: from " ++ show paddr ++ " without content"

        packet sock paddr (TrChannelRequest ref) (obj:objs) pst ist = do
            logd $ "Got channel request: from " ++ show paddr
            logd $ show (obj:objs)
            ref' <- storeObject ist obj
            if ref == ref'
               then do forM_ objs $ storeObject ist
                       copyRef pst ref >>= \case
                           Nothing -> logd $ "Incomplete channel request"
                           Just sref -> do
                               let request = wrappedLoad sref :: Stored ChannelRequest
                               modifyMVar_ peers $ \pval -> case M.lookup paddr pval of
                                   Just peer | Just pid <- peerIdentity peer ->
                                       runExceptT (acceptChannelRequest sidentity pid request) >>= \case
                                           Left errs -> do mapM_ logd ("Invalid channel request" : errs)
                                                           return pval
                                           Right (acc, channel) -> do
                                               logd $ "Got channel: " ++ show (storedRef channel)
                                               let peer' = peer { peerChannels = fromStored channel : peerChannels peer }
                                               writeChan chanPeer peer'
                                               void $ sendTo sock (BL.toStrict $ BL.concat
                                                   [ serializeObject $ transportToObject $ TrChannelAccept (partialRef ist $ storedRef acc)
                                                   , lazyLoadBytes $ storedRef acc
                                                   , lazyLoadBytes $ storedRef $ signedData $ fromStored acc
                                                   , lazyLoadBytes $ storedRef $ caKey $ fromStored $ signedData $ fromStored acc
                                                   , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored acc
                                                   ]) paddr
                                               return $ M.insert paddr peer' pval

                                   _ -> do logd $ "Invalid channel request - no peer identity"
                                           return pval
               else logd $ "Mismatched content"

        packet _ paddr (TrChannelAccept _) [] _ _ = do
            logd $ "Got channel accept: from " ++ show paddr ++ " without content"

        packet _ paddr (TrChannelAccept ref) (obj:objs) pst ist = do
            logd $ "Got channel accept: from " ++ show paddr
            logd $ show (obj:objs)
            ref' <- storeObject ist obj
            if ref == ref'
               then do forM_ objs $ storeObject ist
                       copyRef pst ref >>= \case
                           Nothing -> logd $ "Incomplete channel accept"
                           Just sref -> do
                               let accepted = wrappedLoad sref :: Stored ChannelAccept
                               modifyMVar_ peers $ \pval -> case M.lookup paddr pval of
                                   Just peer | Just pid <- peerIdentity peer ->
                                       runExceptT (acceptedChannel sidentity pid accepted) >>= \case
                                           Left errs -> do mapM_ logd ("Invalid channel accept" : errs)
                                                           return pval
                                           Right channel -> do
                                               logd $ "Got channel: " ++ show (storedRef channel)
                                               let peer' = peer { peerChannels = fromStored channel : peerChannels peer }
                                               writeChan chanPeer peer'
                                               return $ M.insert paddr peer' pval
                                   _ -> do logd $ "Invalid channel accept - no peer identity"
                                           return pval

               else logd $ "Mismatched content"

    void $ forkIO $ withSocketsDo $ do
        let hints = defaultHints
              { addrFlags = [AI_PASSIVE]
              , addrSocketType = Datagram
              }
        addr:_ <- getAddrInfo (Just hints) Nothing (Just discoveryPort)
        bracket (open addr) close loop

    return (chanPeer, chanSvc)


sendToPeer :: Storable a => Stored Identity -> Peer -> T.Text -> a -> IO ()
sendToPeer _ peer@Peer { peerChannels = ch:_ } svc obj = do
    let st = peerInStorage peer
    ref <- store st obj
    Just bytes <- return $ lazyLoadBytes ref
    let plain = BL.toStrict $ BL.concat
            [ serializeObject $ serviceToObject $ ServiceHeader svc ref
            , bytes
            ]
    ctext <- channelEncrypt ch plain
    let DatagramAddress paddr = peerAddress peer
    void $ sendTo (peerSocket peer) ctext paddr

sendToPeer _ _ _ _ = putStrLn $ "No channel to peer"