diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -42,7 +42,7 @@ fi - travis_retry cabal update - "sed -i 's/^jobs:.*$/jobs: 2/' $HOME/.cabal/config" - - cabal install --only-dependencies --enable-tests --dry -v pipes-cacophony.cabal > installplan.txt + - cabal install --only-dependencies --enable-tests -fbuild-examples --dry -v pipes-cacophony.cabal > installplan.txt - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt # check whether current requested install-plan matches cached package-db snapshot @@ -56,7 +56,7 @@ echo "cabal build-cache MISS"; rm -rf $HOME/.cabsnap; mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; - cabal install --only-dependencies --enable-tests pipes-cacophony.cabal; + cabal install --only-dependencies --enable-tests -fbuild-examples pipes-cacophony.cabal; if [ "$GHCVER" = "7.10.1" ]; then cabal install Cabal-1.22.4.0; fi; fi @@ -72,7 +72,7 @@ - cabal install script: - - cabal configure --enable-tests -v2 # -v2 provides useful information for debugging + - cabal configure --enable-tests -fbuild-examples -v2 # -v2 provides useful information for debugging - cabal build # this builds all libraries and executables (including tests) - cabal test - cabal sdist # tests that a source-distribution can be generated @@ -81,4 +81,4 @@ # If there are no other `.tar.gz` files in `dist`, this can be even simpler: # `cabal install --force-reinstalls dist/*-*.tar.gz` - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && - (cd dist && cabal install --enable-tests --run-tests --force-reinstalls "$SRC_TGZ") + (cd dist && cabal install --enable-tests -fbuild-examples --run-tests --force-reinstalls "$SRC_TGZ") diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,11 @@ +# 0.1.2 + +* Added examples to Travis config + +* Brought unit tests and examples up to date with cacophony API changes + +* Improved examples + # 0.1.1 * Enabled test verification on sdist package (for unit testing) diff --git a/examples/echo-client/Handshakes.hs b/examples/echo-client/Handshakes.hs new file mode 100644 --- /dev/null +++ b/examples/echo-client/Handshakes.hs @@ -0,0 +1,408 @@ +{-# LANGUAGE DeriveGeneric, RankNTypes, ImpredicativeTypes, + OverloadedStrings, RecordWildCards #-} + +module Handshakes + ( HandshakeKeys(..), + HandshakeType(..), + processHandshake + ) where + +import Control.Concurrent.Async (race_) +import Control.Concurrent.MVar (MVar, newEmptyMVar) +import Control.Exception (Exception, throw, throwIO) +import Data.Aeson (ToJSON, FromJSON, parseJSON, (.:), + Value(..), (.=), toJSON, object, withObject) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64 as B64 (encode, decode) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import qualified Data.Text as T (concat) +import Data.Typeable (Typeable) +import GHC.Generics +import Pipes +import Pipes.Aeson +import Pipes.Parse +import qualified Pipes.ByteString as P + +import Crypto.Noise.Handshake +import Crypto.Noise.HandshakePatterns +import Crypto.Noise.Cipher +import Crypto.Noise.Cipher.ChaChaPoly1305 +import Crypto.Noise.Curve +import Crypto.Noise.Curve.Curve25519 +import Crypto.Noise.Hash.SHA256 + +import Pipes.Noise + +data HandshakeKeys = + HandshakeKeys { psk :: Maybe Plaintext + , initStatic :: KeyPair Curve25519 + , respStatic :: PublicKey Curve25519 + , respEphemeral :: PublicKey Curve25519 + } + +data HandshakeException = HandshakeFailed + | InvalidHandshakeType Text + | Base64DecodingFailure String + deriving (Show, Typeable) + +instance Exception HandshakeException + +data HandshakeType = NoiseNN + | NoiseKN + | NoiseNK + | NoiseKK + | NoiseNE + | NoiseKE + | NoiseNX + | NoiseKX + | NoiseXN + | NoiseIN + | NoiseXK + | NoiseIK + | NoiseXE + | NoiseIE + | NoiseXX + | NoiseIX + +instance ToJSON HandshakeType where + toJSON (NoiseNN) = String . makeHSN $ "NN" + toJSON (NoiseKN) = String . makeHSN $ "KN" + toJSON (NoiseNK) = String . makeHSN $ "NK" + toJSON (NoiseKK) = String . makeHSN $ "KK" + toJSON (NoiseNE) = String . makeHSN $ "NE" + toJSON (NoiseKE) = String . makeHSN $ "KE" + toJSON (NoiseNX) = String . makeHSN $ "NX" + toJSON (NoiseKX) = String . makeHSN $ "KX" + toJSON (NoiseXN) = String . makeHSN $ "XN" + toJSON (NoiseIN) = String . makeHSN $ "IN" + toJSON (NoiseXK) = String . makeHSN $ "XK" + toJSON (NoiseIK) = String . makeHSN $ "IK" + toJSON (NoiseXE) = String . makeHSN $ "XE" + toJSON (NoiseIE) = String . makeHSN $ "IE" + toJSON (NoiseXX) = String . makeHSN $ "XX" + toJSON (NoiseIX) = String . makeHSN $ "IX" + +data InitialMessage = + InitialMessage { handshakeType :: HandshakeType + } deriving (Generic) + +instance ToJSON InitialMessage + +newtype HandshakeMessage = HandshakeMessage ByteString + +instance FromJSON HandshakeMessage where + parseJSON = withObject "handshake data" $ + \o -> pure + . either + (throw . Base64DecodingFailure) + HandshakeMessage + . B64.decode + . encodeUtf8 + =<< (o .: "handshakeData") + +instance ToJSON HandshakeMessage where + toJSON (HandshakeMessage hm) = + object [ "handshakeData" .= encodedData ] + where + encodedData = decodeUtf8 . B64.encode $ hm + +newtype Message = Message ByteString + +instance FromJSON Message where + parseJSON = withObject "message" $ + \o -> pure + . either + (throw . Base64DecodingFailure) + Message + . B64.decode + . encodeUtf8 + =<< (o .: "message") + +instance ToJSON Message where + toJSON (Message m) = + object [ "message" .= encodedData ] + where + encodedData = decodeUtf8 . B64.encode $ m + +type ClientReceiver = Producer' ByteString IO () +type ClientSender = Consumer' ByteString IO () + +makeHSN :: Text -> Text +makeHSN ht = T.concat ["Noise_", ht, "_25519_ChaChaPoly_SHA256"] + +processHandshake :: HandshakeKeys + -> (ClientSender, ClientReceiver) + -> HandshakeType + -> IO () +processHandshake hks (cs, cr) ht = do + csmv <- newEmptyMVar + + let im = InitialMessage ht + imo = case toJSON im of + (Object o) -> o + _ -> undefined + + runEffect $ encodeObject imo >-> cs + + runEffect $ cr >-> deserializeHM >-> mkHandshakePipe ht hks csmv >-> serializeHM >-> cs + + putStrLn "Handshake complete" + + race_ (runEffect (P.stdin >-> messageEncryptPipe csmv >-> serializeM >-> cs)) + (runEffect (cr >-> deserializeM >-> messageDecryptPipe csmv >-> P.stdout)) + +deserializeHM :: Pipe ByteString ByteString IO () +deserializeHM = parseForever_ decode >-> grabResult + where + grabResult = do + mer <- await + case mer of + Left e -> lift $ throwIO e + Right (HandshakeMessage r) -> yield r + grabResult + +serializeHM :: Pipe ByteString ByteString IO () +serializeHM = encodeResult >-> for cat encodeObject + where + encodeResult = do + hm <- await + case toJSON . HandshakeMessage $ hm of + (Object o) -> yield o + _ -> undefined + encodeResult + +deserializeM :: Pipe ByteString ByteString IO () +deserializeM = parseForever_ decode >-> grabResult + where + grabResult = do + mer <- await + case mer of + Left e -> lift $ throwIO e + Right (Message r) -> yield r + grabResult + +serializeM :: Pipe ByteString ByteString IO () +serializeM = encodeResult >-> for cat encodeObject + where + encodeResult = do + m <- await + case toJSON . Message $ m of + (Object o) -> yield o + _ -> undefined + encodeResult + +mkHandshakePipe :: HandshakeType + -> HandshakeKeys + -> MVar (CipherStatePair ChaChaPoly1305) + -> HandshakePipe IO () +mkHandshakePipe ht hks csmv = + case ht of + NoiseNN -> noiseNNIPipe (noiseNNIHS hks) csmv + NoiseKN -> noiseKNIPipe (noiseKNIHS hks) csmv + NoiseNK -> noiseNKIPipe (noiseNKIHS hks) csmv + NoiseKK -> noiseKKIPipe (noiseKKIHS hks) csmv + NoiseNE -> noiseNEIPipe (noiseNEIHS hks) csmv + NoiseKE -> noiseKEIPipe (noiseKEIHS hks) csmv + NoiseNX -> noiseNXIPipe (noiseNXIHS hks) csmv + NoiseKX -> noiseKXIPipe (noiseKXIHS hks) csmv + NoiseXN -> noiseXNIPipe (noiseXNIHS hks) csmv + NoiseIN -> noiseINIPipe (noiseINIHS hks) csmv + NoiseXK -> noiseXKIPipe (noiseXKIHS hks) csmv + NoiseIK -> noiseIKIPipe (noiseIKIHS hks) csmv + NoiseXE -> noiseXEIPipe (noiseXEIHS hks) csmv + NoiseIE -> noiseIEIPipe (noiseIEIHS hks) csmv + NoiseXX -> noiseXXIPipe (noiseXXIHS hks) csmv + NoiseIX -> noiseIXIPipe (noiseIXIHS hks) csmv + +noiseNNIHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseNNIHS HandshakeKeys{..} = + handshakeState + noiseNNI + "" + psk + Nothing + Nothing + Nothing + Nothing + +noiseKNIHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseKNIHS HandshakeKeys{..} = + handshakeState + noiseKNI + "" + psk + (Just initStatic) + Nothing + Nothing + Nothing + +noiseNKIHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseNKIHS HandshakeKeys{..} = + handshakeState + noiseNKI + "" + psk + Nothing + Nothing + (Just respStatic) + Nothing + +noiseKKIHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseKKIHS HandshakeKeys{..} = + handshakeState + noiseKKI + "" + psk + (Just initStatic) + Nothing + (Just respStatic) + Nothing + +noiseNEIHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseNEIHS HandshakeKeys{..} = + handshakeState + noiseNEI + "" + psk + Nothing + Nothing + (Just respStatic) + (Just respEphemeral) + +noiseKEIHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseKEIHS HandshakeKeys{..} = + handshakeState + noiseKEI + "" + psk + (Just initStatic) + Nothing + (Just respStatic) + (Just respEphemeral) + +noiseNXIHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseNXIHS HandshakeKeys{..} = + handshakeState + noiseNXI + "" + psk + Nothing + Nothing + Nothing + Nothing + +noiseKXIHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseKXIHS HandshakeKeys{..} = + handshakeState + noiseKXI + "" + psk + (Just initStatic) + Nothing + (Just respStatic) + Nothing + +noiseXNIHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseXNIHS HandshakeKeys{..} = + handshakeState + noiseXNI + "" + psk + (Just initStatic) + Nothing + Nothing + Nothing + +noiseINIHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseINIHS HandshakeKeys{..} = + handshakeState + noiseINI + "" + psk + (Just initStatic) + Nothing + Nothing + Nothing + +noiseXKIHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseXKIHS HandshakeKeys{..} = + handshakeState + noiseXKI + "" + psk + (Just initStatic) + Nothing + (Just respStatic) + Nothing + +noiseIKIHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseIKIHS HandshakeKeys{..} = + handshakeState + noiseIKI + "" + psk + (Just initStatic) + Nothing + (Just respStatic) + Nothing + +noiseXEIHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseXEIHS HandshakeKeys{..} = + handshakeState + noiseXEI + "" + psk + (Just initStatic) + Nothing + (Just respStatic) + (Just respEphemeral) + +noiseIEIHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseIEIHS HandshakeKeys{..} = + handshakeState + noiseIEI + "" + psk + (Just initStatic) + Nothing + (Just respStatic) + (Just respEphemeral) + +noiseXXIHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseXXIHS HandshakeKeys{..} = + handshakeState + noiseXXI + "" + psk + (Just initStatic) + Nothing + Nothing + Nothing + +noiseIXIHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseIXIHS HandshakeKeys{..} = + handshakeState + noiseIXI + "" + psk + (Just initStatic) + Nothing + Nothing + Nothing diff --git a/examples/echo-client/Main.hs b/examples/echo-client/Main.hs --- a/examples/echo-client/Main.hs +++ b/examples/echo-client/Main.hs @@ -3,21 +3,26 @@ module Main where import Data.ByteString (readFile, writeFile) +import Data.ByteString.Char8 (pack) import Data.Traversable (forM) import Pipes.Network.TCP import Prelude hiding (readFile, writeFile) import System.Directory (doesFileExist) import System.Environment (getArgs) +import Crypto.Noise.Cipher (Plaintext(..)) import Crypto.Noise.Curve import Crypto.Noise.Curve.Curve25519 import Crypto.Noise.Types (bsToSB', sbToBS') import Handshakes -readKey :: FilePath -> IO (KeyPair Curve25519) -readKey f = fmap (curveBytesToPair . bsToSB') (readFile f) +readPrivateKey :: FilePath -> IO (KeyPair Curve25519) +readPrivateKey f = fmap (curveBytesToPair . bsToSB') (readFile f) +readPublicKey :: FilePath -> IO (PublicKey Curve25519) +readPublicKey f = fmap (curveBytesToPub . bsToSB') (readFile f) + genAndWriteKey :: FilePath -> IO (KeyPair Curve25519) genAndWriteKey f = do pair@(sec, pub) <- curveGenKey @@ -25,20 +30,26 @@ writeFile (f `mappend` ".pub") $ (sbToBS' . curvePubToBytes) pub return pair -processKey :: FilePath -> IO (KeyPair Curve25519) -processKey f = do +processPrivateKey :: FilePath -> IO (KeyPair Curve25519) +processPrivateKey f = do exists <- doesFileExist f if exists then - readKey f + readPrivateKey f else genAndWriteKey f main :: IO () main = do - [host, port, htStr] <- getArgs - [is, rs, re] <- forM ["init_static", "resp_static", "resp_ephemeral"] processKey + [host, port, htStr, preshared] <- getArgs - let keys = HandshakeKeys is rs re + is <- processPrivateKey "init_static" + [rs, re] <- forM ["resp_static.pub", "resp_ephemeral.pub"] readPublicKey + + let preshared' = if not (null preshared) then + Just . Plaintext . bsToSB' . pack $ preshared + else + Nothing + keys = HandshakeKeys preshared' is rs re ht = case htStr of "NN" -> NoiseNN "KN" -> NoiseKN diff --git a/examples/echo-server/Handshakes.hs b/examples/echo-server/Handshakes.hs new file mode 100644 --- /dev/null +++ b/examples/echo-server/Handshakes.hs @@ -0,0 +1,412 @@ +{-# LANGUAGE DeriveGeneric, RankNTypes, ImpredicativeTypes, + OverloadedStrings, RecordWildCards #-} + +module Handshakes + ( HandshakeKeys(..), + processHandshake + ) where + +import Control.Concurrent.MVar (MVar, newEmptyMVar) +import Control.Exception (Exception, throw, throwIO) +import Control.Monad (unless) +import Data.Aeson (ToJSON, FromJSON, parseJSON, (.:), + Value(..), (.=), toJSON, object, withObject) +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (pack) +import qualified Data.ByteString.Base64 as B64 (encode, decode) +import Data.Maybe (isNothing, fromJust) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import qualified Data.Text as T (concat) +import Data.Typeable (Typeable) +import GHC.Generics +import Pipes +import Pipes.Aeson +import Pipes.Parse + +import Crypto.Noise.Handshake +import Crypto.Noise.HandshakePatterns +import Crypto.Noise.Cipher +import Crypto.Noise.Cipher.ChaChaPoly1305 +import Crypto.Noise.Curve +import Crypto.Noise.Curve.Curve25519 +import Crypto.Noise.Hash.SHA256 + +import Pipes.Noise + +data HandshakeKeys = + HandshakeKeys { psk :: Maybe Plaintext + , initStatic :: PublicKey Curve25519 + , respStatic :: KeyPair Curve25519 + , respEphemeral :: KeyPair Curve25519 + } + +data HandshakeException = HandshakeFailed + | InvalidHandshakeType Text + | Base64DecodingFailure String + deriving (Show, Typeable) + +instance Exception HandshakeException + +data HandshakeType = NoiseNN + | NoiseKN + | NoiseNK + | NoiseKK + | NoiseNE + | NoiseKE + | NoiseNX + | NoiseKX + | NoiseXN + | NoiseIN + | NoiseXK + | NoiseIK + | NoiseXE + | NoiseIE + | NoiseXX + | NoiseIX + deriving (Show) + +instance FromJSON HandshakeType where + parseJSON (String ht) + | ht == makeHSN "NN" = pure NoiseNN + | ht == makeHSN "KN" = pure NoiseKN + | ht == makeHSN "NK" = pure NoiseNK + | ht == makeHSN "KK" = pure NoiseKK + | ht == makeHSN "NE" = pure NoiseNE + | ht == makeHSN "KE" = pure NoiseKE + | ht == makeHSN "NX" = pure NoiseNX + | ht == makeHSN "KX" = pure NoiseKX + | ht == makeHSN "XN" = pure NoiseXN + | ht == makeHSN "IN" = pure NoiseIN + | ht == makeHSN "XK" = pure NoiseXK + | ht == makeHSN "IK" = pure NoiseIK + | ht == makeHSN "XE" = pure NoiseXE + | ht == makeHSN "IE" = pure NoiseIE + | ht == makeHSN "XX" = pure NoiseXX + | ht == makeHSN "IX" = pure NoiseIX + | otherwise = throw $ InvalidHandshakeType ht + parseJSON _ = mzero + +data InitialMessage = + InitialMessage { handshakeType :: HandshakeType + } deriving (Generic) + +instance FromJSON InitialMessage + +newtype HandshakeMessage = HandshakeMessage ByteString + +instance FromJSON HandshakeMessage where + parseJSON = withObject "handshake data" $ + \o -> pure + . either + (throw . Base64DecodingFailure) + HandshakeMessage + . B64.decode + . encodeUtf8 + =<< (o .: "handshakeData") + +instance ToJSON HandshakeMessage where + toJSON (HandshakeMessage hm) = + object [ "handshakeData" .= encodedData ] + where + encodedData = decodeUtf8 . B64.encode $ hm + +newtype Message = Message ByteString + +instance FromJSON Message where + parseJSON = withObject "message" $ + \o -> pure + . either + (throw . Base64DecodingFailure) + Message + . B64.decode + . encodeUtf8 + =<< (o .: "message") + +instance ToJSON Message where + toJSON (Message m) = + object [ "message" .= encodedData ] + where + encodedData = decodeUtf8 . B64.encode $ m + +type ClientReceiver = Producer' ByteString IO () +type ClientSender = Consumer' ByteString IO () + +makeHSN :: Text -> Text +makeHSN ht = T.concat ["Noise_", ht, "_25519_ChaChaPoly_SHA256"] + +processHandshake :: HandshakeKeys + -> (ClientReceiver, ClientSender) + -> (ByteString -> IO ()) + -> IO () +processHandshake hks (cr, cs) logger = do + csmv <- newEmptyMVar + + mer <- evalStateT decode cr + unless (isNothing mer) $ + case fromJust mer of + Left e -> throwIO e + Right (InitialMessage r) -> do + logger $ "requested handshake: " `mappend` (pack . show) r + runHandshake $ mkHandshakePipe r hks csmv + logger "handshake complete" + + runEffect $ + cr >-> deserializeM >-> messageDecryptPipe csmv >-> messageEncryptPipe csmv >-> serializeM >-> cs + where + runHandshake hp = runEffect $ cr >-> deserializeHM >-> hp >-> serializeHM >-> cs + +deserializeHM :: Pipe ByteString ByteString IO () +deserializeHM = parseForever_ decode >-> grabResult + where + grabResult = do + mer <- await + case mer of + Left e -> lift $ throwIO e + Right (HandshakeMessage r) -> yield r + grabResult + +serializeHM :: Pipe ByteString ByteString IO () +serializeHM = encodeResult >-> for cat encodeObject + where + encodeResult = do + hm <- await + case toJSON . HandshakeMessage $ hm of + (Object o) -> yield o + _ -> undefined + encodeResult + +deserializeM :: Pipe ByteString ByteString IO () +deserializeM = parseForever_ decode >-> grabResult + where + grabResult = do + mer <- await + case mer of + Left e -> lift $ throwIO e + Right (Message r) -> yield r + grabResult + +serializeM :: Pipe ByteString ByteString IO () +serializeM = encodeResult >-> for cat encodeObject + where + encodeResult = do + m <- await + case toJSON . Message $ m of + (Object o) -> yield o + _ -> undefined + encodeResult + +mkHandshakePipe :: HandshakeType + -> HandshakeKeys + -> MVar (CipherStatePair ChaChaPoly1305) + -> HandshakePipe IO () +mkHandshakePipe ht hks csmv = + case ht of + NoiseNN -> noiseNNRPipe (noiseNNRHS hks) csmv + NoiseKN -> noiseKNRPipe (noiseKNRHS hks) csmv + NoiseNK -> noiseNKRPipe (noiseNKRHS hks) csmv + NoiseKK -> noiseKKRPipe (noiseKKRHS hks) csmv + NoiseNE -> noiseNERPipe (noiseNERHS hks) csmv + NoiseKE -> noiseKERPipe (noiseKERHS hks) csmv + NoiseNX -> noiseNXRPipe (noiseNXRHS hks) csmv + NoiseKX -> noiseKXRPipe (noiseKXRHS hks) csmv + NoiseXN -> noiseXNRPipe (noiseXNRHS hks) csmv + NoiseIN -> noiseINRPipe (noiseINRHS hks) csmv + NoiseXK -> noiseXKRPipe (noiseXKRHS hks) csmv + NoiseIK -> noiseIKRPipe (noiseIKRHS hks) csmv + NoiseXE -> noiseXERPipe (noiseXERHS hks) csmv + NoiseIE -> noiseIERPipe (noiseIERHS hks) csmv + NoiseXX -> noiseXXRPipe (noiseXXRHS hks) csmv + NoiseIX -> noiseIXRPipe (noiseIXRHS hks) csmv + +noiseNNRHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseNNRHS HandshakeKeys{..} = + handshakeState + noiseNNR + "" + psk + Nothing + Nothing + Nothing + Nothing + +noiseKNRHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseKNRHS HandshakeKeys{..} = + handshakeState + noiseKNR + "" + psk + Nothing + Nothing + (Just initStatic) + Nothing + +noiseNKRHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseNKRHS HandshakeKeys{..} = + handshakeState + noiseNKR + "" + psk + (Just respStatic) + Nothing + Nothing + Nothing + +noiseKKRHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseKKRHS HandshakeKeys{..} = + handshakeState + noiseKKR + "" + psk + (Just respStatic) + Nothing + (Just initStatic) + Nothing + +noiseNERHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseNERHS HandshakeKeys{..} = + handshakeState + noiseNER + "" + psk + (Just respStatic) + (Just respEphemeral) + Nothing + Nothing + +noiseKERHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseKERHS HandshakeKeys{..} = + handshakeState + noiseKER + "" + psk + (Just respStatic) + (Just respEphemeral) + (Just initStatic) + Nothing + +noiseNXRHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseNXRHS HandshakeKeys{..} = + handshakeState + noiseNXR + "" + psk + (Just respStatic) + Nothing + Nothing + Nothing + +noiseKXRHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseKXRHS HandshakeKeys{..} = + handshakeState + noiseKXR + "" + psk + (Just respStatic) + Nothing + (Just initStatic) + Nothing + +noiseXNRHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseXNRHS HandshakeKeys{..} = + handshakeState + noiseXNR + "" + psk + Nothing + Nothing + Nothing + Nothing + +noiseINRHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseINRHS HandshakeKeys{..} = + handshakeState + noiseINR + "" + psk + Nothing + Nothing + Nothing + Nothing + +noiseXKRHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseXKRHS HandshakeKeys{..} = + handshakeState + noiseXKR + "" + psk + (Just respStatic) + Nothing + Nothing + Nothing + +noiseIKRHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseIKRHS HandshakeKeys{..} = + handshakeState + noiseIKR + "" + psk + (Just respStatic) + Nothing + Nothing + Nothing + +noiseXERHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseXERHS HandshakeKeys{..} = + handshakeState + noiseXER + "" + psk + (Just respStatic) + (Just respEphemeral) + Nothing + Nothing + +noiseIERHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseIERHS HandshakeKeys{..} = + handshakeState + noiseIER + "" + psk + (Just respStatic) + (Just respEphemeral) + Nothing + Nothing + +noiseXXRHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseXXRHS HandshakeKeys{..} = + handshakeState + noiseXXR + "" + psk + (Just respStatic) + Nothing + Nothing + Nothing + +noiseIXRHS :: HandshakeKeys + -> HandshakeState ChaChaPoly1305 Curve25519 SHA256 +noiseIXRHS HandshakeKeys{..} = + handshakeState + noiseIXR + "" + psk + (Just respStatic) + Nothing + Nothing + Nothing diff --git a/examples/echo-server/Main.hs b/examples/echo-server/Main.hs --- a/examples/echo-server/Main.hs +++ b/examples/echo-server/Main.hs @@ -6,7 +6,7 @@ import Control.Exception (SomeException, displayException, handle) import Data.Aeson (encode, object, (.=)) import Data.ByteString (ByteString, readFile, writeFile) -import Data.ByteString.Char8 (unpack) +import Data.ByteString.Char8 (pack, unpack) import Data.ByteString.Lazy.Char8 (append) import Data.Traversable (forM) import Data.UnixTime (formatUnixTime, fromEpochTime) @@ -18,15 +18,19 @@ import System.Posix (epochTime) import System.Posix.Files (setFileCreationMask) +import Crypto.Noise.Cipher (Plaintext(..)) import Crypto.Noise.Curve import Crypto.Noise.Curve.Curve25519 import Crypto.Noise.Types (bsToSB', sbToBS') import Handshakes -readKey :: FilePath -> IO (KeyPair Curve25519) -readKey f = fmap (curveBytesToPair . bsToSB') (readFile f) +readPrivateKey :: FilePath -> IO (KeyPair Curve25519) +readPrivateKey f = fmap (curveBytesToPair . bsToSB') (readFile f) +readPublicKey :: FilePath -> IO (PublicKey Curve25519) +readPublicKey f = fmap (curveBytesToPub . bsToSB') (readFile f) + genAndWriteKey :: FilePath -> IO (KeyPair Curve25519) genAndWriteKey f = do pair@(sec, pub) <- curveGenKey @@ -34,34 +38,57 @@ writeFile (f `mappend` ".pub") $ (sbToBS' . curvePubToBytes) pub return pair -processKey :: FilePath -> IO (KeyPair Curve25519) -processKey f = do +processPrivateKey :: FilePath -> IO (KeyPair Curve25519) +processPrivateKey f = do exists <- doesFileExist f if exists then - readKey f + readPrivateKey f else genAndWriteKey f main :: IO () main = do - [port] <- getArgs - [is, rs, re] <- forM ["init_static", "resp_static", "resp_ephemeral"] processKey + [port, preshared] <- getArgs + [rs, re] <- forM ["resp_static", "resp_ephemeral"] processPrivateKey + is <- readPublicKey "init_static.pub" logHandle <- openLog "debug.log" au <- mkAutoUpdate defaultUpdateSettings { updateAction = getDateTime } - let exLogger = logException logHandle au - keys = HandshakeKeys is rs re + let exLogger = logException logHandle au + preshared' = if not (null preshared) then + Just . Plaintext . bsToSB' . pack $ preshared + else + Nothing + keys = HandshakeKeys preshared' is rs re serve HostAny port $ \(s, ip) -> do let clientReceiver = fromSocketTimeout 120000000 s 4096 clientSender = toSocket s - handle (exLogger ip) $ processHandshake keys (clientReceiver, clientSender) + logMsg logHandle au ip "connection established" + handle (exLogger ip) $ processHandshake + keys + (clientReceiver, clientSender) + (logMsg logHandle au ip) + logMsg logHandle au ip "connection closed" openLog :: FilePath -> IO LoggerSet openLog file = do _ <- setFileCreationMask 0o000 newFileLoggerSet 1 file + +logMsg :: LoggerSet + -> IO ByteString + -> SockAddr + -> ByteString + -> IO () +logMsg ls getCachedDate ip msg = do + zdt <- getCachedDate + (pushLogStr ls . toLogStr) . (`append` "\n") . encode $ + object [ "date" .= unpack zdt + , "message" .= unpack msg + , "ip" .= show ip + ] logException :: LoggerSet -> IO ByteString diff --git a/pipes-cacophony.cabal b/pipes-cacophony.cabal --- a/pipes-cacophony.cabal +++ b/pipes-cacophony.cabal @@ -1,5 +1,5 @@ name: pipes-cacophony -version: 0.1.1 +version: 0.1.2 synopsis: Pipes for Noise-secured network connections. license: PublicDomain license-file: LICENSE @@ -88,6 +88,9 @@ else buildable: False + other-modules: + Handshakes + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fwarn-tabs executable echo-client @@ -114,14 +117,17 @@ else buildable: False + other-modules: + Handshakes + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fwarn-tabs -------------------------------------------------------------------------------- -- TESTS -test-suite test-pipes-cacophony +test-suite properties type: exitcode-stdio-1.0 - main-is: Tests.hs + main-is: properties.hs ghc-options: -Wall -fwarn-tabs hs-source-dirs: tests default-language: Haskell2010 @@ -139,11 +145,10 @@ tasty-quickcheck other-modules: - Handshake, + Handshakes, HandshakeStates, Imports, - Instances, - Tests + Instances test-suite hlint type: exitcode-stdio-1.0 diff --git a/tests/Handshake.hs b/tests/Handshake.hs deleted file mode 100644 --- a/tests/Handshake.hs +++ /dev/null @@ -1,158 +0,0 @@ -{-# LANGUAGE OverloadedStrings, RankNTypes #-} -module Handshake where - -import Control.Concurrent.Async (concurrently) -import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, - putMVar, newMVar) -import Control.Monad (forever) -import Data.ByteString (ByteString) - -import Crypto.Noise.Cipher.ChaChaPoly1305 - -import Pipes hiding (Proxy) -import Pipes.Noise - -import HandshakeStates -import Imports -import Instances() - -data HandshakeType = NoiseNN - | NoiseKN - | NoiseNK - | NoiseKK - | NoiseNE - | NoiseKE - | NoiseNX - | NoiseKX - | NoiseXN - | NoiseIN - | NoiseXK - | NoiseIK - | NoiseXE - | NoiseIE - | NoiseXX - | NoiseIX - | NoiseN - | NoiseK - | NoiseX - deriving (Eq) - -mkHandshakePipe :: HandshakeType - -> MVar (CipherStatePair ChaChaPoly1305) - -> MVar (CipherStatePair ChaChaPoly1305) - -> (HandshakePipe IO (), HandshakePipe IO ()) -mkHandshakePipe ht csmv1 csmv2 = - case ht of - NoiseNN -> (noiseNNIPipe noiseNNIHS csmv1, - noiseNNRPipe noiseNNRHS csmv2) - NoiseKN -> (noiseKNIPipe noiseKNIHS csmv1, - noiseKNRPipe noiseKNRHS csmv2) - NoiseNK -> (noiseNKIPipe noiseNKIHS csmv1, - noiseNKRPipe noiseNKRHS csmv2) - NoiseKK -> (noiseKKIPipe noiseKKIHS csmv1, - noiseKKRPipe noiseKKRHS csmv2) - NoiseNE -> (noiseNEIPipe noiseNEIHS csmv1, - noiseNERPipe noiseNERHS csmv2) - NoiseKE -> (noiseKEIPipe noiseKEIHS csmv1, - noiseKERPipe noiseKERHS csmv2) - NoiseNX -> (noiseNXIPipe noiseNXIHS csmv1, - noiseNXRPipe noiseNXRHS csmv2) - NoiseKX -> (noiseKXIPipe noiseKXIHS csmv1, - noiseKXRPipe noiseKXRHS csmv2) - NoiseXN -> (noiseXNIPipe noiseXNIHS csmv1, - noiseXNRPipe noiseXNRHS csmv2) - NoiseIN -> (noiseINIPipe noiseINIHS csmv1, - noiseINRPipe noiseINRHS csmv2) - NoiseXK -> (noiseXKIPipe noiseXKIHS csmv1, - noiseXKRPipe noiseXKRHS csmv2) - NoiseIK -> (noiseIKIPipe noiseIKIHS csmv1, - noiseIKRPipe noiseIKRHS csmv2) - NoiseXE -> (noiseXEIPipe noiseXEIHS csmv1, - noiseXERPipe noiseXERHS csmv2) - NoiseIE -> (noiseIEIPipe noiseIEIHS csmv1, - noiseIERPipe noiseIERHS csmv2) - NoiseXX -> (noiseXXIPipe noiseXXIHS csmv1, - noiseXXRPipe noiseXXRHS csmv2) - NoiseIX -> (noiseIXIPipe noiseIXIHS csmv1, - noiseIXRPipe noiseIXRHS csmv2) - NoiseN -> (noiseNIPipe noiseNIHS csmv1, - noiseNRPipe noiseNRHS csmv2) - NoiseK -> (noiseKIPipe noiseKIHS csmv1, - noiseKRPipe noiseKRHS csmv2) - NoiseX -> (noiseXIPipe noiseXIHS csmv1, - noiseXRPipe noiseXRHS csmv2) - -aggregator :: MVar [ByteString] - -> Consumer' ByteString IO () -aggregator mv = forever $ do - bs <- await - l <- lift $ takeMVar mv - lift $ putMVar mv (bs : l) - -mVarProducer :: MVar ByteString - -> Producer' ByteString IO () -mVarProducer mv = forever $ do - x <- lift $ takeMVar mv - yield x - -mVarConsumer :: MVar ByteString - -> Consumer' ByteString IO () -mVarConsumer mv = forever $ do - x <- await - lift $ putMVar mv x - -runPipe :: HandshakeType -> Property -runPipe ht = ioProperty $ do - resultsmv <- newMVar [] - msgmv1 <- newEmptyMVar - msgmv2 <- newEmptyMVar - csmv1 <- newEmptyMVar - csmv2 <- newEmptyMVar - - let (initPipe, respPipe) = mkHandshakePipe ht csmv1 csmv2 - - _ <- concurrently (runEffect (mVarProducer msgmv1 >-> initPipe >-> mVarConsumer msgmv2)) - (runEffect (mVarProducer msgmv2 >-> respPipe >-> mVarConsumer msgmv1)) - - testData <- generate . listOf1 $ arbitrary - - if ht == NoiseN || ht == NoiseK || ht == NoiseX then - runEffect $ - each testData - >-> messageEncryptPipe csmv1 - >-> messageDecryptPipe csmv2 - >-> aggregator resultsmv - else - runEffect $ - each testData - >-> messageEncryptPipe csmv1 - >-> messageDecryptPipe csmv2 - >-> messageEncryptPipe csmv2 - >-> messageDecryptPipe csmv1 - >-> aggregator resultsmv - - results <- takeMVar resultsmv - return $ reverse results === testData - -tests :: TestTree -tests = testGroup "Handshakes" - [ testProperty "Noise_NN" . property . runPipe $ NoiseNN - , testProperty "Noise_KN" . property . runPipe $ NoiseKN - , testProperty "Noise_NK" . property . runPipe $ NoiseNK - , testProperty "Noise_KK" . property . runPipe $ NoiseKK - , testProperty "Noise_NE" . property . runPipe $ NoiseNE - , testProperty "Noise_KE" . property . runPipe $ NoiseKE - , testProperty "Noise_NX" . property . runPipe $ NoiseNX - , testProperty "Noise_KX" . property . runPipe $ NoiseKX - , testProperty "Noise_XN" . property . runPipe $ NoiseXN - , testProperty "Noise_IN" . property . runPipe $ NoiseIN - , testProperty "Noise_XK" . property . runPipe $ NoiseXK - , testProperty "Noise_IK" . property . runPipe $ NoiseIK - , testProperty "Noise_XE" . property . runPipe $ NoiseXE - , testProperty "Noise_IE" . property . runPipe $ NoiseIE - , testProperty "Noise_XX" . property . runPipe $ NoiseXX - , testProperty "Noise_IX" . property . runPipe $ NoiseIX - , testProperty "Noise_N" . property . runPipe $ NoiseN - , testProperty "Noise_K" . property . runPipe $ NoiseK - , testProperty "Noise_X" . property . runPipe $ NoiseX - ] diff --git a/tests/HandshakeStates.hs b/tests/HandshakeStates.hs --- a/tests/HandshakeStates.hs +++ b/tests/HandshakeStates.hs @@ -21,9 +21,9 @@ noiseNNIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseNNIHS = handshakeState - "NN" noiseNNI "" + (Just "cacophony") Nothing Nothing Nothing @@ -32,9 +32,9 @@ noiseKNIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseKNIHS = handshakeState - "KN" noiseKNI "" + (Just "cacophony") (Just initStatic) Nothing Nothing @@ -43,9 +43,9 @@ noiseNKIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseNKIHS = handshakeState - "NK" noiseNKI "" + (Just "cacophony") Nothing Nothing (Just (snd respStatic)) @@ -54,9 +54,9 @@ noiseKKIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseKKIHS = handshakeState - "KK" noiseKKI "" + (Just "cacophony") (Just initStatic) Nothing (Just (snd respStatic)) @@ -65,9 +65,9 @@ noiseNEIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseNEIHS = handshakeState - "NE" noiseNEI "" + (Just "cacophony") Nothing Nothing (Just (snd respStatic)) @@ -76,9 +76,9 @@ noiseKEIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseKEIHS = handshakeState - "KE" noiseKEI "" + (Just "cacophony") (Just initStatic) Nothing (Just (snd respStatic)) @@ -87,9 +87,9 @@ noiseNXIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseNXIHS = handshakeState - "NX" noiseNXI "" + (Just "cacophony") Nothing Nothing Nothing @@ -98,20 +98,20 @@ noiseKXIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseKXIHS = handshakeState - "KX" noiseKXI "" + (Just "cacophony") (Just initStatic) Nothing - (Just (snd respStatic)) Nothing + Nothing noiseXNIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseXNIHS = handshakeState - "XN" noiseXNI "" + (Just "cacophony") (Just initStatic) Nothing Nothing @@ -120,9 +120,9 @@ noiseINIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseINIHS = handshakeState - "IN" noiseINI "" + (Just "cacophony") (Just initStatic) Nothing Nothing @@ -131,9 +131,9 @@ noiseXKIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseXKIHS = handshakeState - "XK" noiseXKI "" + (Just "cacophony") (Just initStatic) Nothing (Just (snd respStatic)) @@ -142,9 +142,9 @@ noiseIKIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseIKIHS = handshakeState - "IK" noiseIKI "" + (Just "cacophony") (Just initStatic) Nothing (Just (snd respStatic)) @@ -153,9 +153,9 @@ noiseXEIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseXEIHS = handshakeState - "XE" noiseXEI "" + (Just "cacophony") (Just initStatic) Nothing (Just (snd respStatic)) @@ -164,9 +164,9 @@ noiseIEIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseIEIHS = handshakeState - "IE" noiseIEI "" + (Just "cacophony") (Just initStatic) Nothing (Just (snd respStatic)) @@ -175,9 +175,9 @@ noiseXXIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseXXIHS = handshakeState - "XX" noiseXXI "" + (Just "cacophony") (Just initStatic) Nothing Nothing @@ -186,9 +186,9 @@ noiseIXIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseIXIHS = handshakeState - "IX" noiseIXI "" + (Just "cacophony") (Just initStatic) Nothing Nothing @@ -197,9 +197,9 @@ noiseNIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseNIHS = handshakeState - "N" noiseNI "" + (Just "cacophony") Nothing Nothing (Just (snd respStatic)) @@ -208,9 +208,9 @@ noiseKIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseKIHS = handshakeState - "K" noiseKI "" + (Just "cacophony") (Just initStatic) Nothing (Just (snd respStatic)) @@ -219,9 +219,9 @@ noiseXIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseXIHS = handshakeState - "X" noiseXI "" + (Just "cacophony") (Just initStatic) Nothing (Just (snd respStatic)) @@ -230,9 +230,9 @@ noiseNNRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseNNRHS = handshakeState - "NN" noiseNNR "" + (Just "cacophony") Nothing Nothing Nothing @@ -241,9 +241,9 @@ noiseKNRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseKNRHS = handshakeState - "KN" noiseKNR "" + (Just "cacophony") Nothing Nothing (Just (snd initStatic)) @@ -252,9 +252,9 @@ noiseNKRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseNKRHS = handshakeState - "NK" noiseNKR "" + (Just "cacophony") (Just respStatic) Nothing Nothing @@ -263,9 +263,9 @@ noiseKKRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseKKRHS = handshakeState - "KK" noiseKKR "" + (Just "cacophony") (Just respStatic) Nothing (Just (snd initStatic)) @@ -274,9 +274,9 @@ noiseNERHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseNERHS = handshakeState - "NE" noiseNER "" + (Just "cacophony") (Just respStatic) (Just respEphemeral) Nothing @@ -285,9 +285,9 @@ noiseKERHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseKERHS = handshakeState - "KE" noiseKER "" + (Just "cacophony") (Just respStatic) (Just respEphemeral) (Just (snd initStatic)) @@ -296,9 +296,9 @@ noiseNXRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseNXRHS = handshakeState - "NX" noiseNXR "" + (Just "cacophony") (Just respStatic) Nothing Nothing @@ -307,9 +307,9 @@ noiseKXRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseKXRHS = handshakeState - "KX" noiseKXR "" + (Just "cacophony") (Just respStatic) Nothing (Just (snd initStatic)) @@ -318,9 +318,9 @@ noiseXNRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseXNRHS = handshakeState - "XN" noiseXNR "" + (Just "cacophony") Nothing Nothing Nothing @@ -329,9 +329,9 @@ noiseINRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseINRHS = handshakeState - "IN" noiseINR "" + (Just "cacophony") Nothing Nothing Nothing @@ -340,9 +340,9 @@ noiseXKRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseXKRHS = handshakeState - "XK" noiseXKR "" + (Just "cacophony") (Just respStatic) Nothing Nothing @@ -351,9 +351,9 @@ noiseIKRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseIKRHS = handshakeState - "IK" noiseIKR "" + (Just "cacophony") (Just respStatic) Nothing Nothing @@ -362,9 +362,9 @@ noiseXERHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseXERHS = handshakeState - "XE" noiseXER "" + (Just "cacophony") (Just respStatic) (Just respEphemeral) Nothing @@ -373,9 +373,9 @@ noiseIERHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseIERHS = handshakeState - "IE" noiseIER "" + (Just "cacophony") (Just respStatic) (Just respEphemeral) Nothing @@ -384,9 +384,9 @@ noiseXXRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseXXRHS = handshakeState - "XX" noiseXXR "" + (Just "cacophony") (Just respStatic) Nothing Nothing @@ -395,9 +395,9 @@ noiseIXRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseIXRHS = handshakeState - "IX" noiseIXR "" + (Just "cacophony") (Just respStatic) Nothing Nothing @@ -406,9 +406,9 @@ noiseNRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseNRHS = handshakeState - "N" noiseNR "" + (Just "cacophony") (Just respStatic) Nothing Nothing @@ -417,9 +417,9 @@ noiseKRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseKRHS = handshakeState - "K" noiseKR "" + (Just "cacophony") (Just respStatic) Nothing (Just (snd initStatic)) @@ -428,9 +428,9 @@ noiseXRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 noiseXRHS = handshakeState - "X" noiseXR "" + (Just "cacophony") (Just respStatic) Nothing Nothing diff --git a/tests/Handshakes.hs b/tests/Handshakes.hs new file mode 100644 --- /dev/null +++ b/tests/Handshakes.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE OverloadedStrings, RankNTypes #-} +module Handshakes where + +import Control.Concurrent.Async (concurrently) +import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, + putMVar, newMVar) +import Control.Monad (forever) +import Data.ByteString (ByteString) + +import Crypto.Noise.Cipher.ChaChaPoly1305 + +import Pipes hiding (Proxy) +import Pipes.Noise + +import HandshakeStates +import Imports +import Instances() + +data HandshakeType = NoiseNN + | NoiseKN + | NoiseNK + | NoiseKK + | NoiseNE + | NoiseKE + | NoiseNX + | NoiseKX + | NoiseXN + | NoiseIN + | NoiseXK + | NoiseIK + | NoiseXE + | NoiseIE + | NoiseXX + | NoiseIX + | NoiseN + | NoiseK + | NoiseX + deriving (Eq) + +mkHandshakePipe :: HandshakeType + -> MVar (CipherStatePair ChaChaPoly1305) + -> MVar (CipherStatePair ChaChaPoly1305) + -> (HandshakePipe IO (), HandshakePipe IO ()) +mkHandshakePipe ht csmv1 csmv2 = + case ht of + NoiseNN -> (noiseNNIPipe noiseNNIHS csmv1, + noiseNNRPipe noiseNNRHS csmv2) + NoiseKN -> (noiseKNIPipe noiseKNIHS csmv1, + noiseKNRPipe noiseKNRHS csmv2) + NoiseNK -> (noiseNKIPipe noiseNKIHS csmv1, + noiseNKRPipe noiseNKRHS csmv2) + NoiseKK -> (noiseKKIPipe noiseKKIHS csmv1, + noiseKKRPipe noiseKKRHS csmv2) + NoiseNE -> (noiseNEIPipe noiseNEIHS csmv1, + noiseNERPipe noiseNERHS csmv2) + NoiseKE -> (noiseKEIPipe noiseKEIHS csmv1, + noiseKERPipe noiseKERHS csmv2) + NoiseNX -> (noiseNXIPipe noiseNXIHS csmv1, + noiseNXRPipe noiseNXRHS csmv2) + NoiseKX -> (noiseKXIPipe noiseKXIHS csmv1, + noiseKXRPipe noiseKXRHS csmv2) + NoiseXN -> (noiseXNIPipe noiseXNIHS csmv1, + noiseXNRPipe noiseXNRHS csmv2) + NoiseIN -> (noiseINIPipe noiseINIHS csmv1, + noiseINRPipe noiseINRHS csmv2) + NoiseXK -> (noiseXKIPipe noiseXKIHS csmv1, + noiseXKRPipe noiseXKRHS csmv2) + NoiseIK -> (noiseIKIPipe noiseIKIHS csmv1, + noiseIKRPipe noiseIKRHS csmv2) + NoiseXE -> (noiseXEIPipe noiseXEIHS csmv1, + noiseXERPipe noiseXERHS csmv2) + NoiseIE -> (noiseIEIPipe noiseIEIHS csmv1, + noiseIERPipe noiseIERHS csmv2) + NoiseXX -> (noiseXXIPipe noiseXXIHS csmv1, + noiseXXRPipe noiseXXRHS csmv2) + NoiseIX -> (noiseIXIPipe noiseIXIHS csmv1, + noiseIXRPipe noiseIXRHS csmv2) + NoiseN -> (noiseNIPipe noiseNIHS csmv1, + noiseNRPipe noiseNRHS csmv2) + NoiseK -> (noiseKIPipe noiseKIHS csmv1, + noiseKRPipe noiseKRHS csmv2) + NoiseX -> (noiseXIPipe noiseXIHS csmv1, + noiseXRPipe noiseXRHS csmv2) + +aggregator :: MVar [ByteString] + -> Consumer' ByteString IO () +aggregator mv = forever $ do + bs <- await + l <- lift $ takeMVar mv + lift $ putMVar mv (bs : l) + +mVarProducer :: MVar ByteString + -> Producer' ByteString IO () +mVarProducer mv = forever $ do + x <- lift $ takeMVar mv + yield x + +mVarConsumer :: MVar ByteString + -> Consumer' ByteString IO () +mVarConsumer mv = forever $ do + x <- await + lift $ putMVar mv x + +runPipe :: HandshakeType -> Property +runPipe ht = ioProperty $ do + resultsmv <- newMVar [] + msgmv1 <- newEmptyMVar + msgmv2 <- newEmptyMVar + csmv1 <- newEmptyMVar + csmv2 <- newEmptyMVar + + let (initPipe, respPipe) = mkHandshakePipe ht csmv1 csmv2 + + _ <- concurrently (runEffect (mVarProducer msgmv1 >-> initPipe >-> mVarConsumer msgmv2)) + (runEffect (mVarProducer msgmv2 >-> respPipe >-> mVarConsumer msgmv1)) + + testData <- generate . listOf1 $ arbitrary + + if ht == NoiseN || ht == NoiseK || ht == NoiseX then + runEffect $ + each testData + >-> messageEncryptPipe csmv1 + >-> messageDecryptPipe csmv2 + >-> aggregator resultsmv + else + runEffect $ + each testData + >-> messageEncryptPipe csmv1 + >-> messageDecryptPipe csmv2 + >-> messageEncryptPipe csmv2 + >-> messageDecryptPipe csmv1 + >-> aggregator resultsmv + + results <- takeMVar resultsmv + return $ reverse results === testData + +tests :: TestTree +tests = testGroup "Handshakes" + [ testProperty "Noise_NN" . property . runPipe $ NoiseNN + , testProperty "Noise_KN" . property . runPipe $ NoiseKN + , testProperty "Noise_NK" . property . runPipe $ NoiseNK + , testProperty "Noise_KK" . property . runPipe $ NoiseKK + , testProperty "Noise_NE" . property . runPipe $ NoiseNE + , testProperty "Noise_KE" . property . runPipe $ NoiseKE + , testProperty "Noise_NX" . property . runPipe $ NoiseNX + , testProperty "Noise_KX" . property . runPipe $ NoiseKX + , testProperty "Noise_XN" . property . runPipe $ NoiseXN + , testProperty "Noise_IN" . property . runPipe $ NoiseIN + , testProperty "Noise_XK" . property . runPipe $ NoiseXK + , testProperty "Noise_IK" . property . runPipe $ NoiseIK + , testProperty "Noise_XE" . property . runPipe $ NoiseXE + , testProperty "Noise_IE" . property . runPipe $ NoiseIE + , testProperty "Noise_XX" . property . runPipe $ NoiseXX + , testProperty "Noise_IX" . property . runPipe $ NoiseIX + , testProperty "Noise_N" . property . runPipe $ NoiseN + , testProperty "Noise_K" . property . runPipe $ NoiseK + , testProperty "Noise_X" . property . runPipe $ NoiseX + ] diff --git a/tests/Tests.hs b/tests/Tests.hs deleted file mode 100644 --- a/tests/Tests.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Main where - -import Imports - -import qualified Handshake - -tests :: TestTree -tests = testGroup "cacophony" - [ Handshake.tests - ] - -main :: IO () -main = defaultMain tests diff --git a/tests/properties.hs b/tests/properties.hs new file mode 100644 --- /dev/null +++ b/tests/properties.hs @@ -0,0 +1,13 @@ +module Main where + +import Imports + +import qualified Handshakes + +tests :: TestTree +tests = testGroup "pipes-cacophony" + [ Handshakes.tests + ] + +main :: IO () +main = defaultMain tests