summaryrefslogtreecommitdiff
path: root/src/Network.hs
blob: 6609667504a62b93e4c054d8069b99e9f6d6d3a9 (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
module Network (
    Peer(..),
    PeerAddress,
    peerDiscovery,
) 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.Text as T

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

import Identity
import Storage


discoveryPort :: ServiceName
discoveryPort = "29665"


data Peer = Peer
    { peerIdentity :: Stored Identity
    , peerAddress :: PeerAddress
    }
    deriving (Show)

data PeerAddress = DatagramAddress SockAddr
    deriving (Show)


data TransportHeader = AnnouncePacket Ref
                     | IdentityRequest Ref Ref
                     | IdentityResponse Ref

transportToObject :: TransportHeader -> Object
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)
        ]

transportFromObject :: Object -> 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

transportFromObject _ = Nothing


peerDiscovery :: String -> Stored Identity -> IO (Chan Peer)
peerDiscovery bhost sidentity = do
    chan <- newChan
    void $ forkIO $ withSocketsDo $ do
        let hints = defaultHints
              { addrFlags = [AI_PASSIVE]
              , addrSocketType = Datagram
              }
        addr:_ <- getAddrInfo (Just hints) Nothing (Just discoveryPort)
        bracket (open addr) close (loop chan)
    return chan
  where
    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 chan sock = do
        baddr:_ <- getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just bhost) (Just discoveryPort)
        void $ sendTo sock (BL.toStrict $ serializeObject $ transportToObject $ AnnouncePacket $ storedRef sidentity) (addrAddress baddr)
        forever $ do
            (msg, peer) <- recvFrom sock 4096
            let packet' = packet chan sock peer
            case runExcept $ deserializeObjects (storedStorage sidentity) $ BL.fromStrict msg of
                 Left err -> putStrLn $ show peer ++ ": " ++ err
                 Right (obj:objs) | Just tpack <- transportFromObject obj -> packet' tpack objs
                 _ -> putStrLn $ show peer ++ ": invalid transport packet"

    packet _ sock peer (AnnouncePacket ref) _ = do
        putStrLn $ "Got announce: " ++ show ref ++ " from " ++ show peer
        void $ sendTo sock (BL.toStrict $ BL.concat
            [ serializeObject $ transportToObject $ IdentityRequest ref (storedRef sidentity)
            , lazyLoadBytes $ storedRef sidentity
            ]) peer

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

    packet chan sock peer (IdentityRequest ref from) objs@(obj:_) = do
        putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show peer
        print objs
        from' <- store (storedStorage sidentity) obj
        if from == from'
           then do writeChan chan $ Peer (wrappedLoad from) (DatagramAddress peer)
                   void $ sendTo sock (BL.toStrict $ BL.concat
                       [ serializeObject $ transportToObject $ IdentityResponse (storedRef sidentity)
                       , lazyLoadBytes $ storedRef sidentity
                       ]) peer
           else putStrLn $ "Mismatched content"

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

    packet chan _ peer (IdentityResponse ref) objs@(obj:_) = do
        putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show peer
        print objs
        ref' <- store (storedStorage sidentity) obj
        if ref == ref'
           then writeChan chan $ Peer (wrappedLoad ref) (DatagramAddress peer)
           else putStrLn $ "Mismatched content"