diff options
Diffstat (limited to 'src/Network/Tox/Crypto/Handlers.hs')
-rw-r--r-- | src/Network/Tox/Crypto/Handlers.hs | 103 |
1 files changed, 91 insertions, 12 deletions
diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs index 29f55e54..c5476371 100644 --- a/src/Network/Tox/Crypto/Handlers.hs +++ b/src/Network/Tox/Crypto/Handlers.hs | |||
@@ -12,27 +12,48 @@ import Crypto.Hash | |||
12 | import Control.Applicative | 12 | import Control.Applicative |
13 | import Control.Monad | 13 | import Control.Monad |
14 | import Data.Time.Clock.POSIX | 14 | import Data.Time.Clock.POSIX |
15 | import qualified Data.ByteString as B | ||
16 | import Control.Lens | ||
17 | import Data.Function | ||
18 | import Data.Serialize as S | ||
19 | import Data.Word | ||
20 | import GHC.Conc (unsafeIOToSTM) | ||
21 | |||
22 | -- util, todo: move to another module | ||
23 | maybeToEither (Just x) = Right x | ||
24 | maybeToEither Nothing = Left "maybeToEither" | ||
15 | 25 | ||
16 | data NetCryptoSessionStatus = Unaccepted | Accepted | Confirmed | 26 | data NetCryptoSessionStatus = Unaccepted | Accepted | Confirmed |
17 | deriving (Eq,Ord,Show,Enum) | 27 | deriving (Eq,Ord,Show,Enum) |
18 | 28 | ||
19 | 29 | ||
30 | type IOHook addr x = addr -> x -> IO (Maybe (x -> x)) | ||
31 | type NetCryptoHook = IOHook SockAddr CryptoData | ||
32 | |||
33 | |||
20 | data NetCryptoSession = NCrypto { ncState :: TVar NetCryptoSessionStatus | 34 | data NetCryptoSession = NCrypto { ncState :: TVar NetCryptoSessionStatus |
21 | , ncTheirPacketNonce:: TVar Nonce24 -- base nonce + packet number | 35 | , ncTheirBaseNonce :: TVar Nonce24 -- base nonce + packet number |
22 | , ncMyPacketNonce :: TVar Nonce24 -- base nonce + packet number | 36 | , ncMyPacketNonce :: TVar Nonce24 -- base nonce + packet number |
23 | , ncHandShake :: TVar (Maybe (Handshake Encrypted)) | 37 | , ncHandShake :: TVar (Maybe (Handshake Encrypted)) |
24 | , ncCookie :: TVar (Maybe Cookie) | 38 | , ncCookie :: TVar (Maybe Cookie) |
25 | , ncTheirSessionPublic :: Maybe PublicKey | 39 | , ncTheirSessionPublic :: Maybe PublicKey |
26 | , ncSessionSecret :: SecretKey | 40 | , ncSessionSecret :: SecretKey |
27 | , ncSockAddr :: SockAddr | 41 | , ncSockAddr :: SockAddr |
42 | , ncHooks :: TVar (Map.Map MessageType [NetCryptoHook]) | ||
28 | } | 43 | } |
29 | 44 | ||
30 | data NetCryptoSessions = NCSessions { netCryptoSessions :: TVar (Map.Map SockAddr NetCryptoSession) | 45 | data NetCryptoSessions = NCSessions { netCryptoSessions :: TVar (Map.Map SockAddr NetCryptoSession) |
31 | , transportCrypto :: TransportCrypto | 46 | , transportCrypto :: TransportCrypto |
47 | , defaultHooks :: Map.Map MessageType [NetCryptoHook] | ||
32 | } | 48 | } |
33 | 49 | ||
34 | newSessionsState :: TransportCrypto -> IO NetCryptoSessions | 50 | newSessionsState :: TransportCrypto -> Map.Map MessageType [NetCryptoHook] -> IO NetCryptoSessions |
35 | newSessionsState crypto = error "todo" | 51 | newSessionsState crypto hooks = do |
52 | x <- atomically $ newTVar Map.empty | ||
53 | return NCSessions { netCryptoSessions = x | ||
54 | , transportCrypto = crypto | ||
55 | , defaultHooks = hooks | ||
56 | } | ||
36 | 57 | ||
37 | data HandshakeParams | 58 | data HandshakeParams |
38 | = HParam | 59 | = HParam |
@@ -48,6 +69,7 @@ newHandShakeData = error "todo" | |||
48 | 69 | ||
49 | cryptoNetHandler :: NetCryptoSessions -> SockAddr -> NetCrypto -> IO (Maybe (NetCrypto -> NetCrypto)) | 70 | cryptoNetHandler :: NetCryptoSessions -> SockAddr -> NetCrypto -> IO (Maybe (NetCrypto -> NetCrypto)) |
50 | cryptoNetHandler sessions addr (NetHandshake (Handshake (Cookie n24 ecookie) nonce24 encrypted)) = do | 71 | cryptoNetHandler sessions addr (NetHandshake (Handshake (Cookie n24 ecookie) nonce24 encrypted)) = do |
72 | -- Handle Handshake Message | ||
51 | let crypto = transportCrypto sessions | 73 | let crypto = transportCrypto sessions |
52 | allsessions = netCryptoSessions sessions | 74 | allsessions = netCryptoSessions sessions |
53 | anyRight xs f = foldr1 (<|>) $ map f xs | 75 | anyRight xs f = foldr1 (<|>) $ map f xs |
@@ -81,17 +103,18 @@ cryptoNetHandler sessions addr (NetHandshake (Handshake (Cookie n24 ecookie) non | |||
81 | Left _ -> return () | 103 | Left _ -> return () |
82 | Right hp@(HParam | 104 | Right hp@(HParam |
83 | { hpTheirBaseNonce = Just theirBaseNonce | 105 | { hpTheirBaseNonce = Just theirBaseNonce |
84 | , hpOtherCookie = Just otherCookie | 106 | , hpOtherCookie = Just otherCookie |
85 | , hpTheirSessionKeyPublic = theirSessionKey | 107 | , hpTheirSessionKeyPublic = theirSessionKey |
86 | , hpMySecretKey = key | 108 | , hpMySecretKey = key |
87 | , hpCookieRemotePubkey = remotePublicKey | 109 | , hpCookieRemotePubkey = remotePublicKey |
88 | , hpCookieRemoteDhtkey = remoteDhtPublicKey | 110 | , hpCookieRemoteDhtkey = remoteDhtPublicKey |
89 | }) -> do | 111 | }) -> do |
90 | sessionsmap <- atomically $ readTVar allsessions | 112 | sessionsmap <- atomically $ readTVar allsessions |
113 | -- Do a lookup, in case we decide to handle the update case differently | ||
91 | case Map.lookup addr sessionsmap of | 114 | case Map.lookup addr sessionsmap of |
92 | Nothing -> do -- create new session | 115 | _ -> do -- create new session |
93 | ncState0 <- atomically $ newTVar Accepted | 116 | ncState0 <- atomically $ newTVar Accepted |
94 | ncTheirPacketNonce0 <- atomically $ newTVar theirBaseNonce | 117 | ncTheirBaseNonce0 <- atomically $ newTVar theirBaseNonce |
95 | n24 <- atomically $ transportNewNonce crypto | 118 | n24 <- atomically $ transportNewNonce crypto |
96 | let myhandshakeData = newHandShakeData crypto hp | 119 | let myhandshakeData = newHandShakeData crypto hp |
97 | plain = encodePlain myhandshakeData | 120 | plain = encodePlain myhandshakeData |
@@ -105,22 +128,78 @@ cryptoNetHandler sessions addr (NetHandshake (Handshake (Cookie n24 ecookie) non | |||
105 | ncHandShake0 <- atomically $ newTVar (Just myhandshake) | 128 | ncHandShake0 <- atomically $ newTVar (Just myhandshake) |
106 | cookie0 <- atomically $ newTVar (Just otherCookie) | 129 | cookie0 <- atomically $ newTVar (Just otherCookie) |
107 | newsession <- generateSecretKey | 130 | newsession <- generateSecretKey |
131 | ncHooks0 <- atomically $ newTVar (defaultHooks sessions) | ||
108 | let netCryptoSession = | 132 | let netCryptoSession = |
109 | NCrypto { ncState = ncState0 | 133 | NCrypto { ncState = ncState0 |
110 | , ncTheirPacketNonce= ncTheirPacketNonce0 | 134 | , ncTheirBaseNonce= ncTheirBaseNonce0 |
111 | , ncMyPacketNonce = ncMyPacketNonce0 | 135 | , ncMyPacketNonce = ncMyPacketNonce0 |
112 | , ncHandShake = ncHandShake0 | 136 | , ncHandShake = ncHandShake0 |
113 | , ncCookie = cookie0 | 137 | , ncCookie = cookie0 |
114 | , ncTheirSessionPublic = Just theirSessionKey | 138 | , ncTheirSessionPublic = Just theirSessionKey |
115 | , ncSessionSecret = newsession | 139 | , ncSessionSecret = newsession |
116 | , ncSockAddr = addr | 140 | , ncSockAddr = addr |
141 | , ncHooks = ncHooks0 | ||
117 | } | 142 | } |
118 | atomically $ modifyTVar allsessions (Map.insert addr netCryptoSession) | 143 | atomically $ modifyTVar allsessions (Map.insert addr netCryptoSession) |
119 | Just netCryptoSession -> return () -- TODO: UPdate existing session | ||
120 | return Nothing | 144 | return Nothing |
121 | cryptoNetHandler sessions addr (NetCrypto (CryptoPacket nonce16 encrypted)) = do | 145 | cryptoNetHandler sessions addr (NetCrypto (CryptoPacket nonce16 encrypted)) = do |
122 | let crypto = transportCrypto sessions | 146 | let crypto = transportCrypto sessions |
147 | allsessions = netCryptoSessions sessions | ||
148 | sessionsmap <- atomically $ readTVar allsessions | ||
123 | -- Handle Encrypted Message | 149 | -- Handle Encrypted Message |
124 | -- TODO | 150 | case Map.lookup addr sessionsmap of |
125 | return Nothing | 151 | Nothing -> return Nothing -- drop packet, we have no session |
126 | -- cryptoNetHandler _ _ _ = return $ Just id | 152 | Just (NCrypto {ncState, ncHooks,ncSessionSecret,ncTheirSessionPublic,ncTheirBaseNonce}) -> do |
153 | theirBaseNonce <- atomically $ readTVar ncTheirBaseNonce | ||
154 | -- Try to decrypt message | ||
155 | let diff :: Word16 | ||
156 | diff = nonce16 - fromIntegral (last2Bytes theirBaseNonce) -- truncating to Word16 | ||
157 | tempNonce <- addtoNonce24 theirBaseNonce (fromIntegral diff) -- expanding to Word | ||
158 | let lr = do -- Either Monad -- | ||
159 | pubkey <- maybeToEither ncTheirSessionPublic | ||
160 | decodePlain =<< decrypt (computeSharedSecret ncSessionSecret pubkey tempNonce) encrypted | ||
161 | case lr of | ||
162 | Left _ -> return Nothing -- decryption failed, ignore packet | ||
163 | Right cd@(CryptoData {bufferStart, bufferEnd, bufferData=cm}) -> do -- decryption succeeded, | ||
164 | -- TODO: Why do I need bufferStart & bufferEnd? | ||
165 | -- | ||
166 | -- buffer_start = highest packet number handled + 1 | ||
167 | -- , recvbuffers buffer_start | ||
168 | -- | ||
169 | -- bufferEnd = sendbuffer buffer_end if lossy, otherwise packet number | ||
170 | -- update ncTheirBaseNonce if necessary | ||
171 | when (diff > 2 * dATA_NUM_THRESHOLD)$ | ||
172 | atomically $ do | ||
173 | y <- readTVar ncTheirBaseNonce | ||
174 | -- all because Storable forces IO... | ||
175 | x <- unsafeIOToSTM $ addtoNonce24 y (fromIntegral dATA_NUM_THRESHOLD) | ||
176 | writeTVar ncTheirBaseNonce y | ||
177 | -- then set session confirmed, | ||
178 | atomically $ writeTVar ncState Confirmed | ||
179 | hookmap <- atomically $ readTVar ncHooks | ||
180 | -- run hook | ||
181 | flip fix cd $ \lookupAgain cd -> do | ||
182 | let msgTyp = cd ^. messageType | ||
183 | case Map.lookup msgTyp hookmap of | ||
184 | Nothing -> return Nothing -- discarding, because no hooks | ||
185 | Just hooks -> flip fix (hooks,cd,msgTyp) $ \loop (hooks,cd,typ) -> do | ||
186 | let _ = cd :: CryptoData | ||
187 | case (hooks,cd) of | ||
188 | ([],_) -> return Nothing | ||
189 | (hook:more,cd) -> do | ||
190 | r <- hook addr cd :: IO (Maybe (CryptoData -> CryptoData)) | ||
191 | case r of | ||
192 | Just f -> let newcd = f cd | ||
193 | newtyp = newcd ^. messageType | ||
194 | in if newtyp == typ then loop (more,newcd,newtyp) | ||
195 | else lookupAgain newcd | ||
196 | Nothing -> return Nothing -- message consumed | ||
197 | where | ||
198 | last2Bytes :: Nonce24 -> Word | ||
199 | last2Bytes (Nonce24 bs) = case S.decode (B.drop 22 bs) of | ||
200 | Right n -> n | ||
201 | _ -> error "unreachable-last2Bytes" | ||
202 | dATA_NUM_THRESHOLD = 21845 -- = 65535 / 3 | ||
203 | |||
204 | |||
205 | cryptoDefaultHooks = Map.empty | ||