pipes-cacophony 0.1.1 → 0.1.2
raw patch · 12 files changed
+1110/−239 lines, 12 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- .travis.yml +4/−4
- changelog.md +8/−0
- examples/echo-client/Handshakes.hs +408/−0
- examples/echo-client/Main.hs +19/−8
- examples/echo-server/Handshakes.hs +412/−0
- examples/echo-server/Main.hs +38/−11
- pipes-cacophony.cabal +11/−6
- tests/Handshake.hs +0/−158
- tests/HandshakeStates.hs +39/−39
- tests/Handshakes.hs +158/−0
- tests/Tests.hs +0/−13
- tests/properties.hs +13/−0
.travis.yml view
@@ -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")
changelog.md view
@@ -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)
+ examples/echo-client/Handshakes.hs view
@@ -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
examples/echo-client/Main.hs view
@@ -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
+ examples/echo-server/Handshakes.hs view
@@ -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
examples/echo-server/Main.hs view
@@ -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
pipes-cacophony.cabal view
@@ -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
− tests/Handshake.hs
@@ -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- ]
tests/HandshakeStates.hs view
@@ -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
+ tests/Handshakes.hs view
@@ -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+ ]
− tests/Tests.hs
@@ -1,13 +0,0 @@-module Main where--import Imports--import qualified Handshake--tests :: TestTree-tests = testGroup "cacophony"- [ Handshake.tests- ]--main :: IO ()-main = defaultMain tests
+ tests/properties.hs view
@@ -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