diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Channel.hs | 57 | ||||
| -rw-r--r-- | src/Network.hs | 12 |
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) |