summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Channel.hs57
-rw-r--r--src/Network.hs12
2 files changed, 34 insertions, 35 deletions
diff --git a/src/Channel.hs b/src/Channel.hs
index ad88190..625d526 100644
--- a/src/Channel.hs
+++ b/src/Channel.hs
@@ -11,20 +11,21 @@ module Channel (
channelDecrypt,
) where
+import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.Except
import Crypto.Cipher.AES
import Crypto.Cipher.Types
import Crypto.Error
-import Crypto.Random
+import Data.Binary
import Data.ByteArray
-import qualified Data.ByteArray as BA
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as B
+import Data.ByteArray qualified as BA
+import Data.ByteString qualified as B
+import Data.ByteString.Lazy qualified as BL
import Data.List
-import qualified Data.Text as T
+import Data.Text qualified as T
import Identity
import PubKey
@@ -33,8 +34,10 @@ import Storage
data Channel = Channel
{ chPeers :: [Stored (Signed IdentityData)]
, chKey :: ScrubbedBytes
+ , chNonceFixedOur :: Bytes
+ , chNonceFixedPeer :: Bytes
+ , chNonceCounter :: MVar Word64
}
- deriving (Show)
type ChannelRequest = Signed ChannelRequestData
@@ -52,19 +55,6 @@ data ChannelAcceptData = ChannelAccept
}
-instance Storable Channel where
- store' ch = storeRec $ do
- mapM_ (storeRef "peer") $ chPeers ch
- storeText "enc" $ T.pack "aes-128-gcm"
- storeBinary "key" $ chKey ch
-
- load' = loadRec $ do
- enc <- loadText "enc"
- guard $ enc == "aes-128-gcm"
- Channel
- <$> loadRefs "peer"
- <*> loadBinary "key"
-
instance Storable ChannelRequestData where
store' cr = storeRec $ do
mapM_ (storeRef "peer") $ crPeers cr
@@ -98,7 +88,7 @@ createChannelRequest st self peer = liftIO $ do
Just skey <- loadKey $ idKeyMessage self
wrappedStore st =<< sign skey =<< wrappedStore st ChannelRequest { crPeers = sort [idData self, idData peer], crKey = xpublic }
-acceptChannelRequest :: (MonadIO m, MonadError String m) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelRequest -> m (Stored ChannelAccept, Stored Channel)
+acceptChannelRequest :: (MonadIO m, MonadError String m) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelRequest -> m (Stored ChannelAccept, Channel)
acceptChannelRequest self peer req = do
when ((crPeers $ fromStored $ signedData $ fromStored req) /= sort (map idData [self, peer])) $
throwError $ "mismatched peers in channel request"
@@ -111,17 +101,19 @@ acceptChannelRequest self peer req = do
(xsecret, xpublic) <- generateKeys st
Just skey <- loadKey $ idKeyMessage self
acc <- wrappedStore st =<< sign skey =<< wrappedStore st ChannelAccept { caRequest = req, caKey = xpublic }
- ch <- wrappedStore st Channel
+ counter <- newMVar 0
+ return $ (acc,) $ Channel
{ chPeers = crPeers $ fromStored $ signedData $ fromStored req
, chKey = BA.take ksize $ dhSecret xsecret $
fromStored $ crKey $ fromStored $ signedData $ fromStored req
+ , chNonceFixedOur = BA.pack [ 2, 0, 0, 0, 0, 0 ]
+ , chNonceFixedPeer = BA.pack [ 1, 0, 0, 0, 0, 0 ]
+ , chNonceCounter = counter
}
- return (acc, ch)
-acceptedChannel :: (MonadIO m, MonadError String m) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelAccept -> m (Stored Channel)
+acceptedChannel :: (MonadIO m, MonadError String m) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelAccept -> m Channel
acceptedChannel self peer acc = do
- let st = storedStorage acc
- req = caRequest $ fromStored $ signedData $ fromStored acc
+ let req = caRequest $ fromStored $ signedData $ fromStored acc
KeySizeFixed ksize = cipherKeySize (undefined :: AES128)
when ((crPeers $ fromStored $ signedData $ fromStored req) /= sort (map idData [self, peer])) $
@@ -134,10 +126,14 @@ acceptedChannel self peer acc = do
xsecret <- liftIO (loadKey $ crKey $ fromStored $ signedData $ fromStored req) >>= \case
Just key -> return key
Nothing -> throwError $ "secret key not found"
- liftIO $ wrappedStore st Channel
+ counter <- liftIO $ newMVar 0
+ return $ Channel
{ chPeers = crPeers $ fromStored $ signedData $ fromStored req
, chKey = BA.take ksize $ dhSecret xsecret $
fromStored $ caKey $ fromStored $ signedData $ fromStored acc
+ , chNonceFixedOur = BA.pack [ 1, 0, 0, 0, 0, 0 ]
+ , chNonceFixedPeer = BA.pack [ 2, 0, 0, 0, 0, 0 ]
+ , chNonceCounter = counter
}
@@ -147,12 +143,14 @@ channelEncrypt ch plain = do
CryptoPassed (cipher :: AES128) -> return cipher
_ -> throwError "failed to init AES128 cipher"
let bsize = blockSize cipher
- (iv :: ByteString) <- liftIO $ getRandomBytes 12
+ count <- liftIO $ modifyMVar (chNonceCounter ch) $ \c -> return (c + 1, c)
+ let cbytes = convert $ BL.toStrict $ BL.drop 2 $ encode count
+ iv = chNonceFixedOur ch `append` cbytes
aead <- case aeadInit AEAD_GCM cipher iv of
CryptoPassed aead -> return aead
_ -> throwError "failed to init AEAD_GCM"
let (tag, ctext) = aeadSimpleEncrypt aead B.empty plain bsize
- return $ BA.concat [ convert iv, ctext, convert tag ]
+ return $ BA.concat [ BA.pack [ 0, 0 ], convert cbytes, ctext, convert tag ]
channelDecrypt :: (ByteArray ba, MonadError String m) => Channel -> ba -> m ba
channelDecrypt ch body = do
@@ -160,7 +158,8 @@ channelDecrypt ch body = do
CryptoPassed (cipher :: AES128) -> return cipher
_ -> throwError "failed to init AES128 cipher"
let bsize = blockSize cipher
- (iv, body') = BA.splitAt 12 body
+ (cbytes, body') = BA.splitAt 8 body
+ iv = chNonceFixedPeer ch `append` convert (BA.drop 2 cbytes)
(ctext, tag) = BA.splitAt (BA.length body' - bsize) body'
aead <- case aeadInit AEAD_GCM cipher iv of
CryptoPassed aead -> return aead
diff --git a/src/Network.hs b/src/Network.hs
index e27c2a3..e78ae7c 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -138,7 +138,7 @@ data PeerIdentity = PeerIdentityUnknown (TVar [UnifiedIdentity -> ExceptT String
data PeerChannel = ChannelWait
| ChannelOurRequest (Stored ChannelRequest)
| ChannelPeerRequest WaitingRef
- | ChannelOurAccept (Stored ChannelAccept) (Stored Channel)
+ | ChannelOurAccept (Stored ChannelAccept) Channel
| ChannelEstablished Channel
peerIdentity :: MonadIO m => Peer -> m PeerIdentity
@@ -328,9 +328,9 @@ startServer opt origHead logd' services = do
case M.lookup paddr pvalue of
Just peer -> do
mbch <- atomically (readTVar (peerChannel peer)) >>= return . \case
- ChannelEstablished ch -> Just ch
- ChannelOurAccept _ sch -> Just $ fromStored sch
- _ -> Nothing
+ ChannelEstablished ch -> Just ch
+ ChannelOurAccept _ ch -> Just ch
+ _ -> Nothing
if | Just ch <- mbch
, Right plain <- runExcept $ channelDecrypt ch msg
@@ -492,7 +492,7 @@ handlePacket origHead identity secure peer chanSvc svcs (TransportHeader headers
Acknowledged ref -> do
readTVarP (peerChannel peer) >>= \case
ChannelOurAccept acc ch | refDigest (storedRef acc) == refDigest ref -> do
- writeTVarP (peerChannel peer) $ ChannelEstablished (fromStored ch)
+ writeTVarP (peerChannel peer) $ ChannelEstablished ch
liftSTM $ finalizedChannel peer origHead identity
_ -> return ()
@@ -630,7 +630,7 @@ handleChannelAccept oh identity accref = do
ch <- acceptedChannel identity upid (wrappedLoad acc)
liftIO $ atomically $ do
sendToPeerS peer $ TransportPacket (TransportHeader [Acknowledged accref]) []
- writeTVar (peerChannel peer) $ ChannelEstablished $ fromStored ch
+ writeTVar (peerChannel peer) $ ChannelEstablished ch
finalizedChannel peer oh identity
Left dgst -> throwError $ "missing accept data " ++ BC.unpack (showRefDigest dgst)