Network: secure cookiedevel

Changelog: Secure cookie for connection initialization

1 files changed, 85 insertions, 14 deletions

diff --git a/src/Erebos/Network/Protocol.hs b/src/Erebos/Network/Protocol.hs
index ded0b05..2955473 100644
--- a/src/Erebos/Network/Protocol.hs
+++ b/src/Erebos/Network/Protocol.hs
@@ -40,7 +40,17 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Trans
 
+import Crypto.Cipher.ChaChaPoly1305 qualified as C
+import Crypto.MAC.Poly1305 qualified as C (Auth(..), authTag)
+import Crypto.Error
+import Crypto.Random
+
+import Data.Binary
+import Data.Binary.Get
+import Data.Binary.Put
 import Data.Bits
+import Data.ByteArray (Bytes, ScrubbedBytes)
+import Data.ByteArray qualified as BA
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as B
 import Data.ByteString.Char8 qualified as BC
@@ -51,7 +61,6 @@ import Data.Maybe
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Void
-import Data.Word
 
 import System.Clock
 
@@ -96,14 +105,41 @@ data TransportHeaderItem
     | StreamOpen Word8
     deriving (Eq, Show)
 
-newtype Cookie = Cookie ByteString
-    deriving (Eq, Show)
-
 data SecurityRequirement = PlaintextOnly
                          | PlaintextAllowed
                          | EncryptedOnly
     deriving (Eq, Ord)
 
+data Cookie = Cookie
+    { cookieNonce :: C.Nonce
+    , cookieValidity :: Word32
+    , cookieContent :: ByteString
+    , cookieMac :: C.Auth
+    }
+
+instance Eq Cookie where
+    (==) = (==) `on` (\c -> ( BA.convert (cookieNonce c) :: ByteString, cookieValidity c, cookieContent c, cookieMac c ))
+
+
+instance Show Cookie where
+    show Cookie {..} = show (nonce, cookieValidity, cookieContent, mac)
+      where C.Auth mac = cookieMac
+            nonce = BA.convert cookieNonce :: ByteString
+
+instance Binary Cookie where
+    put Cookie {..} = do
+        putByteString $ BA.convert cookieNonce
+        putWord32be cookieValidity
+        putByteString $ BA.convert cookieMac
+        putByteString cookieContent
+
+    get = do
+        Just cookieNonce <- maybeCryptoError . C.nonce12 <$> getByteString 12
+        cookieValidity <- getWord32be
+        Just cookieMac <- maybeCryptoError . C.authTag <$> getByteString 16
+        cookieContent <- BL.toStrict <$> getRemainingLazyByteString
+        return Cookie {..}
+
 isHeaderItemAcknowledged :: TransportHeaderItem -> Bool
 isHeaderItemAcknowledged = \case
     Acknowledged {} -> False
@@ -123,8 +159,8 @@ transportToObject st (TransportHeader items) = Rec $ map single items
               Rejected dgst -> (BC.pack "REJ", RecRef $ partialRefFromDigest st dgst)
               ProtocolVersion ver -> (BC.pack "VER", RecText ver)
               Initiation dgst -> (BC.pack "INI", RecRef $ partialRefFromDigest st dgst)
-              CookieSet (Cookie bytes) -> (BC.pack "CKS", RecBinary bytes)
-              CookieEcho (Cookie bytes) -> (BC.pack "CKE", RecBinary bytes)
+              CookieSet cookie -> (BC.pack "CKS", RecBinary $ BL.toStrict $ encode cookie)
+              CookieEcho cookie -> (BC.pack "CKE", RecBinary $ BL.toStrict $ encode cookie)
               DataRequest dgst -> (BC.pack "REQ", RecRef $ partialRefFromDigest st dgst)
               DataResponse dgst -> (BC.pack "RSP", RecRef $ partialRefFromDigest st dgst)
               AnnounceSelf dgst -> (BC.pack "ANN", RecRef $ partialRefFromDigest st dgst)
@@ -145,8 +181,12 @@ transportFromObject (Rec items) = case catMaybes $ map single items of
               | name == BC.pack "REJ", RecRef ref <- content -> Just $ Rejected $ refDigest ref
               | name == BC.pack "VER", RecText ver <- content -> Just $ ProtocolVersion ver
               | name == BC.pack "INI", RecRef ref <- content -> Just $ Initiation $ refDigest ref
-              | name == BC.pack "CKS", RecBinary bytes <- content -> Just $ CookieSet (Cookie bytes)
-              | name == BC.pack "CKE", RecBinary bytes <- content -> Just $ CookieEcho (Cookie bytes)
+              | name == BC.pack "CKS", RecBinary bytes <- content
+                                     , Right (_, _, cookie) <- decodeOrFail (BL.fromStrict bytes)
+                                     -> Just $ CookieSet cookie
+              | name == BC.pack "CKE", RecBinary bytes <- content
+                                     , Right (_, _, cookie) <- decodeOrFail (BL.fromStrict bytes)
+                                     -> Just $ CookieEcho cookie
               | name == BC.pack "REQ", RecRef ref <- content -> Just $ DataRequest $ refDigest ref
               | name == BC.pack "RSP", RecRef ref <- content -> Just $ DataResponse $ refDigest ref
               | name == BC.pack "ANN", RecRef ref <- content -> Just $ AnnounceSelf $ refDigest ref
@@ -168,9 +208,12 @@ data GlobalState addr = (Eq addr, Show addr) => GlobalState
     , gNextUp :: TMVar (Connection addr, (Bool, TransportPacket PartialObject))
     , gLog :: String -> STM ()
     , gStorage :: PartialStorage
+    , gStartTime :: TimeSpec
     , gNowVar :: TVar TimeSpec
     , gNextTimeout :: TVar TimeSpec
     , gInitConfig :: Ref
+    , gCookieKey :: ScrubbedBytes
+    , gCookieStartTime :: Word32
     }
 
 data Connection addr = Connection
@@ -444,11 +487,14 @@ erebosNetworkProtocol initialIdentity gLog gDataFlow gControlFlow = do
     mStorage <- memoryStorage
     gStorage <- derivePartialStorage mStorage
 
-    startTime <- getTime Monotonic
-    gNowVar <- newTVarIO startTime
-    gNextTimeout <- newTVarIO startTime
+    gStartTime <- getTime Monotonic
+    gNowVar <- newTVarIO gStartTime
+    gNextTimeout <- newTVarIO gStartTime
     gInitConfig <- store mStorage $ (Rec [] :: Object)
 
+    gCookieKey <- getRandomBytes 32
+    gCookieStartTime <- runGet getWord32host . BL.pack . BA.unpack @ScrubbedBytes <$> getRandomBytes 4
+
     let gs = GlobalState {..}
 
     let signalTimeouts = forever $ do
@@ -702,11 +748,36 @@ generateCookieHeaders Connection {..} ch = catMaybes <$> sequence [ echoHeader,
         _ -> return Nothing
 
 createCookie :: GlobalState addr -> addr -> IO Cookie
-createCookie GlobalState {} addr = return (Cookie $ BC.pack $ show addr)
+createCookie GlobalState {..} addr = do
+    (nonceBytes :: Bytes) <- getRandomBytes 12
+    validUntil <- (fromNanoSecs (60 * 10^(9 :: Int)) +) <$> getTime Monotonic
+    let validSecondsFromStart = fromIntegral $ toNanoSecs (validUntil - gStartTime) `div` (10^(9 :: Int))
+        cookieValidity = validSecondsFromStart - gCookieStartTime
+        plainContent = BC.pack (show addr)
+    throwCryptoErrorIO $ do
+        cookieNonce <- C.nonce12 nonceBytes
+        st1 <- C.initialize gCookieKey cookieNonce
+        let st2 = C.finalizeAAD $ C.appendAAD (BL.toStrict $ runPut $ putWord32be cookieValidity) st1
+            (cookieContent, st3) = C.encrypt plainContent st2
+            cookieMac = C.finalize st3
+        return $ Cookie {..}
 
 verifyCookie :: GlobalState addr -> addr -> Cookie -> IO Bool
-verifyCookie GlobalState {} addr (Cookie cookie) = return $ show addr == BC.unpack cookie
-
+verifyCookie GlobalState {..} addr Cookie {..} = do
+    ctime <- getTime Monotonic
+    return $ fromMaybe False $ maybeCryptoError $ do
+        st1 <- C.initialize gCookieKey cookieNonce
+        let st2 = C.finalizeAAD $ C.appendAAD (BL.toStrict $ runPut $ putWord32be cookieValidity) st1
+            (plainContent, st3) = C.decrypt cookieContent st2
+            mac = C.finalize st3
+
+            validSecondsFromStart = fromIntegral $ cookieValidity + gCookieStartTime
+            validUntil = gStartTime + fromNanoSecs (validSecondsFromStart * (10^(9 :: Int)))
+        return $ and
+            [ mac == cookieMac
+            , ctime <= validUntil
+            , show addr == BC.unpack plainContent
+            ]
 
 reservePacket :: Connection addr -> STM ReservedToSend
 reservePacket conn@Connection {..} = do