aboutsummaryrefslogtreecommitdiff
path: root/src/Ssb/Peer/BoxStream.hs
blob: bb81a12937f5aa35760258aa487a8161ca45c164 (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
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
-- | This module implements Scuttlebutt's Box Stream.
--
-- For more information kindly refer the to protocol guide
-- https://ssbc.github.io/scuttlebutt-protocol-guide

module Ssb.Peer.BoxStream where

import           Protolude               hiding ( Identity )

import qualified Crypto.Hash.SHA256            as SHA256
import qualified Data.ByteString               as BS
import qualified Data.ByteString.Base64        as Base64
import           Data.Either.Combinators        ( mapLeft
                                                , mapRight
                                                )
import           Control.Concurrent.STM
import qualified Data.Serialize                as Serialize
import qualified Data.Serialize.Put            as Serialize
import qualified Network.Simple.TCP            as TCP

import           Ssb.Aux
import qualified Ssb.Identity                  as SSB
import qualified Ssb.Peer.SecretHandshake      as SH

import qualified Crypto.Saltine.Class          as Nacl
import qualified Crypto.Saltine.Core.Auth      as NaclAuth
import qualified Crypto.Saltine.Core.SecretBox as Nacl
import qualified Crypto.Saltine.Core.ScalarMult
                                               as Nacl

import           Pipes
import qualified Pipes.Prelude                 as P

-- | HeaderLength is the length of a Box Stream header in bytes
headerLength :: Int
headerLength = 34

-- | MaxBodyLength is the maximum Box Stream body length in bytes
maxBodyLength :: Int
maxBodyLength = 4096

data Header = Header
    { bodyLength :: Word16
    , authTag    :: AuthTag
    } deriving (Eq,Generic,Show)

instance Serialize.Serialize Header

-- | GoodBye is the message signalling the end of the Box Stream
goodByeHeader :: Header
goodByeHeader = Header
  { bodyLength = 0
  , authTag    = AuthTag $ BS.pack $ replicate authTagLength 0
  }

newHeader :: ByteString -> ByteString -> Either Text Header
newHeader authTag body = do
  let bodyLength = BS.length body
  if bodyLength >= maxLength
    then Left "body size too big"
    else return $ Header { bodyLength = fromIntegral bodyLength
                         , authTag    = AuthTag authTag
                         }
  where maxLength = fromIntegral (maxBound :: Word16)

data Message = Message
  { header :: Header
  , body   :: ByteString
  }

encryptMessage :: Nacl.Key -> Nacl.Nonce -> ByteString -> Either Text ByteString
encryptMessage key nonce buf = do
  let (authTag, ebody) = Nacl.secretboxDetached key bodyNonce buf
  header <- newHeader authTag ebody
  let eheader = Nacl.secretbox key headerNonce $ Serialize.encode header
  return $ eheader <> ebody
 where
  headerNonce = nonce
  bodyNonce   = increment nonce

-- | A breakdown of the message alignment would be nice
-- | Problem is the body size is variable

-- | TODO: deduplicate
-- | TODO: safe take, safe tail

-- TODO: handle goodbye

-- TODO: Properly describe the function w/ Nonce update
--   The decryption / update functions should return the nonce after
--   evaluation.  This increases the difficulty for describing in the language.
--   Current work around is to model the behaviour outside the function.

decryptHeader :: Nacl.Key -> Nacl.Nonce -> ByteString -> Either Text Header
decryptHeader key nonce buf = do
  let eheader = BS.take headerLength buf
  headerBuf <- withErr (errHeader eheader)
    $ Nacl.secretboxOpen key nonce eheader
  decodeByteString headerBuf :: Either Text Header
  where errHeader h = "could not decrypt header: " <> (show h :: Text)

decryptMessage :: Nacl.Key -> Nacl.Nonce -> ByteString -> Either Text ByteString
decryptMessage key nonce buf = do
  header <- decryptHeader key nonce buf

  let rest = BS.drop headerLength buf
  ebody <- withErr "message body is smaller than messages body length"
    $ takeMay (fromIntegral $ bodyLength header) rest
  withErr (errBody ebody) $ Nacl.secretboxOpenDetached
    key
    (increment nonce)
    (extractAuthTag $ authTag header)
    ebody
  where errBody b = "could not decrypt body: " <> (show b :: Text)

goodBye :: ConnState -> ByteString
goodBye state = Nacl.secretbox (key state) (nonce state) $ encodeByteString goodByeHeader

-- | clientToServerKey is the key for client to server stream encryption.
clientToServerKey :: SH.SharedSecrets -> Either Text Nacl.Key
clientToServerKey sharedSecrets = do
  secretB <- withErr errMissingB $ SH.secretB sharedSecrets
  let layer1 = SHA256.hash $ SHA256.hash
        (  SH.network sharedSecrets
        <> Nacl.encode (SH.secretab sharedSecrets)
        <> Nacl.encode (SH.secretaB sharedSecrets)
        <> Nacl.encode (SH.secretAb sharedSecrets)
        )
  let layer2 = SHA256.hash $ layer1 <> SSB.extractPublicKey secretB
  maybeToRight errKey $ Nacl.decode layer2
 where
  errMissingB = "missing shared secret B"
  errKey      = "badly formatted sodium secret box key"

-- | serverToClientKey is the key for server to client stream encryption.
serverToClientKey :: SH.SharedSecrets -> Either Text Nacl.Key
serverToClientKey sharedSecrets = do
  secretA <- withErr errMissingA $ SH.secretA sharedSecrets
  let layer1 = SHA256.hash
        (SHA256.hash
          (  SH.network sharedSecrets
          <> Nacl.encode (SH.secretab sharedSecrets)
          <> Nacl.encode (SH.secretaB sharedSecrets)
          <> Nacl.encode (SH.secretAb sharedSecrets)
          )
        )
  let layer2 = SHA256.hash (layer1 <> SSB.extractPublicKey secretA)
  maybeToRight errKey $ Nacl.decode layer2
 where
  errMissingA = "missing shared secret A"
  errKey      = "badly formatted sodium secret box key"

clientToServerNonce :: SH.SharedSecrets -> Either Text Nacl.Nonce
clientToServerNonce sharedSecrets = do
  secretb <- withErr errMissing $ SH.secretb sharedSecrets
  key     <- withErr errBadNet $ Nacl.decode $ SH.network sharedSecrets
  let auth     = NaclAuth.auth key (SSB.extractPublicKey secretb)
  let noncebuf = BS.take 24 $ Nacl.encode auth
  withErr errMsg $ Nacl.decode noncebuf
 where
  errBadNet  = "badly formatted network id"
  errMissing = "missing shared secret a"
  errMsg     = "badly formatted sodium nonce"

serverToClientNonce :: SH.SharedSecrets -> Either Text Nacl.Nonce
serverToClientNonce sharedSecrets = do
  a   <- withErr errMissing $ SH.secreta sharedSecrets
  key <- withErr errBadNet $ Nacl.decode $ SH.network sharedSecrets
  let auth     = NaclAuth.auth key (SSB.extractPublicKey a)
  let noncebuf = BS.take 24 $ Nacl.encode auth
  withErr errMsg $ Nacl.decode noncebuf
 where
  errMissing = "missing shared secret a"
  errBadNet  = "badly formatted network id"
  errHMAC    = "badly formatted HMAC"
  errMsg     = "badly formatted sodium nonce"

-- The documentation's Client / Server key and nonce terminology is replaced
-- with local/remote fields to simplify implmenentation.
data ConnState = ConnState {
      key           :: Nacl.Key
    , nonce         :: Nacl.Nonce
    , remoteKey     :: Nacl.Key
    , remoteNonce   :: Nacl.Nonce
    , buffer        :: ByteString
    , socket        :: TCP.Socket
    }

newtype Conn = Conn ((TMVar ConnState),(TMVar ConnState))

inc :: (Word64, Word64, Word64) -> (Word64, Word64, Word64)
inc (w1, w2, w3) | w3 /= maxBound = (w1, w2, w3 + 1)
                 | w2 /= maxBound = (w1, w2 + 1, 0)
                 | w1 /= maxBound = (w1 + 1, 0, 0)
                 | otherwise      = (0, 0, 0)


-- TODO : finish me
increment :: Nacl.Nonce -> Nacl.Nonce
increment arg =
  fromMaybe undefined
    $  Nacl.decode
    $  Serialize.encode w1'
    <> Serialize.encode w2'
    <> Serialize.encode w3'
 where
  noncebuf        = Nacl.encode arg
  (b1, e3)        = BS.splitAt 16 noncebuf
  (e1, e2)        = BS.splitAt 8 b1
  w3              = fromRight undefined $ Serialize.decode e3 :: Word64
  w2              = fromRight undefined $ Serialize.decode e2 :: Word64
  w1              = fromRight undefined $ Serialize.decode e1 :: Word64
  (w1', w2', w3') = inc (w1, w2, w3)


-- | TODO: update me for handling multiple encryptions

newConnState :: TCP.Socket -> SH.SharedSecrets -> Either Text ConnState
newConnState socket sharedSecrets =
  ConnState
    <$> clientToServerKey sharedSecrets
    <*> clientToServerNonce sharedSecrets
    <*> serverToClientKey sharedSecrets
    <*> serverToClientNonce sharedSecrets
    <*> Right ""
    <*> Right socket

newServerConnState :: TCP.Socket -> SH.SharedSecrets -> Either Text ConnState
newServerConnState socket sharedSecrets =
  ConnState
    <$> serverToClientKey sharedSecrets
    <*> serverToClientNonce sharedSecrets
    <*> clientToServerKey sharedSecrets
    <*> clientToServerNonce sharedSecrets
    <*> Right ""
    <*> Right socket

-- TODO: Fix underlying network functions
--  Send never seems to fail.
send :: ConnState -> ByteString -> IO (Either Text ())
send state buf = runExceptT (TCP.send (socket state) buf)

read :: ConnState -> Int -> IO (Maybe ByteString)
read state 0     = return Nothing
read state bytes = do
  buf <- TCP.recv (socket state) bytes
  case buf of
    Nothing  -> return Nothing
    Just buf ->
      if BS.length buf == bytes
        then return $ Just buf
        else fmap (buf <>) <$> read state (bytes - BS.length buf)

-- TODO: Keep connection terminology tied to peer and local.
--    Using network terminology such as 'server' can be confusing in other when
--    functions are used in other contexts.
connectClient :: TCP.Socket -> SH.SharedSecrets -> IO (Either Text Conn)
connectClient socket sharedSecrets = do
  let state = newConnState socket sharedSecrets
  case state of
    Left  err   -> return $ Left err
    Right state -> do
      rstate <- newTMVarIO state
      wstate <- newTMVarIO state
      return . return $ Conn (rstate, wstate)

connectServer :: TCP.Socket -> SH.SharedSecrets -> IO (Either Text Conn)
connectServer socket sharedSecrets = do
  let state = newServerConnState socket sharedSecrets
  case state of
    Left  err   -> return $ Left err
    Right state -> do
      rstate <- newTMVarIO state
      wstate <- newTMVarIO state
      return . return $ Conn (rstate, wstate)


disconnect :: ConnState -> IO (Either Text ())
disconnect connState = send connState $ goodBye connState

-- TODO: Find out how to avoid these stair cases

readStream'
  :: ConnState -> Int -> IO (ConnState, Either Text (Maybe ByteString))
readStream' connState bytes = if BS.length (buffer connState) >= bytes
  then do
    let (buf, rem) = BS.splitAt bytes (buffer connState)
    let connState' = connState { buffer = rem }
    return (connState', Right (Just buf))
  else do
    buf <- withErr errNoHeader <$> read connState headerLength
    let header' = buf >>= decryptHeader key' nonce'
    if header' == Right goodByeHeader
        -- TODO: Error if not enough bytes available
      then return (connState, return Nothing)
      else do
        let bodyLength' = bodyLength <$> (buf >>= decryptHeader key' nonce')
        case bodyLength' of
          Left  err         -> return (connState, Left err)
          Right bodyLength' -> do
            ePayload <- withErr errNoBody
              <$> read connState (fromIntegral bodyLength')
            case ePayload of
              Left err -> return (connState, Left err)
              Right payload ->
                case
                    decryptMessage key'
                                   nonce'
                                   (fromRight undefined buf <> payload)
                  of
                    Left  err     -> return (connState, Left err)
                    Right payload -> readStream'
                      (updateNonce . appendBuffer payload $ connState)
                      bytes
 where
  errNoHeader = "could not read header"
  errNoBody   = "could not read body"
  key'        = remoteKey connState
  nonce'      = remoteNonce connState
  updateNonce connState =
    connState { remoteNonce = (increment . increment) (remoteNonce connState) }
  appendBuffer buf connState = connState { buffer = buffer connState <> buf }

readStream :: Conn -> Int -> IO (Either Text (Maybe ByteString))
readStream (Conn (mVar, _)) bytes = do
  state         <- atomically $ takeTMVar mVar
  (state', ret) <- readStream' state bytes
  atomically $ putTMVar mVar state'
  return ret

sendStream' :: ConnState -> ByteString -> IO (ConnState, Either Text ())
sendStream' connState msg = do
  let eMsg = encryptMessage key' nonce' msg
  case eMsg of
    Left  err -> return (connState, Left err)
    Right buf -> do
      ret <- send connState buf
      return (updateNonce connState, ret)
 where
  key'   = key connState
  nonce' = nonce connState
  updateNonce connState =
    connState { nonce = (increment . increment) (nonce connState) }

sendStream :: Conn -> ByteString -> IO (Either Text ())
sendStream (Conn (_, mVar)) buf = do
  state         <- atomically $ takeTMVar mVar
  (state', ret) <- sendStream' state buf
  atomically $ putTMVar mVar state'
  return ret

-- | authTagLength is the AuthTag size in bytes
authTagLength = 16

newtype AuthTag = AuthTag ByteString
  deriving (Eq,Generic,Show)

instance Serialize.Serialize AuthTag where
  get = AuthTag <$> Serialize.getByteString authTagLength
  put (AuthTag buf) = Serialize.putByteString buf

extractAuthTag :: AuthTag -> ByteString
extractAuthTag (AuthTag buf) = buf

-- | Aux functions
takeMay :: Int -> ByteString -> Maybe ByteString
takeMay l arg = if BS.length arg <= l then return $ BS.take l arg else Nothing