diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -13,26 +13,23 @@ matrix: include: - - env: CABALVER=1.22 GHCVER=7.10.1 - compiler: ": #GHC 7.10.1" - addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} - - env: CABALVER=1.22 GHCVER=7.10.2 - compiler: ": #GHC 7.10.2" - addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} - env: CABALVER=1.22 GHCVER=7.10.3 - compiler: ": #GHC 7.10.3" - addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} - - env: CABALVER=1.22 GHCVER=head + compiler: ": #GHC 7.10.2" + addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}} + - env: CABALVER=1.24 GHCVER=8.0.2 + compiler: ": #GHC 8.0.2" + addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}} + - env: CABALVER=head GHCVER=head compiler: ": #GHC head" - addons: {apt: {packages: [cabal-install-1.22,ghc-head,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} + addons: {apt: {packages: [cabal-install-head,ghc-head,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}} allow_failures: - - env: CABALVER=1.22 GHCVER=head + - env: CABALVER=head GHCVER=head before_install: - unset CC - export HAPPYVER=1.19.5 - - export ALEXVER=3.1.4 + - export ALEXVER=3.1.7 - export PATH=~/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/happy/$HAPPYVER/bin:/opt/alex/$ALEXVER/bin:$PATH install: @@ -71,8 +68,6 @@ cp -a $HOME/.ghc $HOME/.cabsnap/ghc; cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; fi - - - cabal install script: - cabal configure --enable-tests -v2 # -v2 provides useful information for debugging diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,8 +1,10 @@ +# 0.3.0 + +* Brought up to date with cacophony API changes + # 0.2.1 * Removed examples - -* Brought up to date with cacophony API changes # 0.2.0 diff --git a/examples/loopback/Main.hs b/examples/loopback/Main.hs new file mode 100644 --- /dev/null +++ b/examples/loopback/Main.hs @@ -0,0 +1,43 @@ +module Main where + +import Control.Lens +import Control.Monad (forever) +import Data.ByteString.Char8 (unpack, pack) +import Pipes +import qualified Pipes.Prelude as P + +import Crypto.Noise +import Crypto.Noise.Cipher.ChaChaPoly1305 +import Crypto.Noise.DH +import Crypto.Noise.DH.Curve25519 +import Crypto.Noise.HandshakePatterns (noiseNN) +import Crypto.Noise.Hash.SHA256 +import Data.ByteArray.Extend + +import Pipes.Noise + +strToSB :: Pipe String ScrubbedBytes IO (Either NoiseException ()) +strToSB = forever $ await >>= yield . convert . pack + +sbToStr :: Pipe ScrubbedBytes String IO (Either NoiseException ()) +sbToStr = forever $ await >>= yield . unpack . convert + +main :: IO () +main = do + iek <- dhGenKey :: IO (KeyPair Curve25519) + rek <- dhGenKey :: IO (KeyPair Curve25519) + + let idho = defaultHandshakeOpts noiseNN InitiatorRole + rdho = defaultHandshakeOpts noiseNN ResponderRole + iho = idho & hoLocalEphemeral .~ Just iek + rho = rdho & hoLocalEphemeral .~ Just rek + ins = noiseState iho :: NoiseState ChaChaPoly1305 Curve25519 SHA256 + rns = noiseState rho :: NoiseState ChaChaPoly1305 Curve25519 SHA256 + + (iip, iop) <- mkNoisePipes ins + (rip, rop) <- mkNoisePipes rns + + result <- runEffect $ (Right () <$ P.stdinLn) >-> strToSB >-> iop >-> rip >-> rop >-> iip >-> sbToStr >-> (Right () <$ P.stdoutLn) + case result of + Left e -> print e + Right _ -> return () 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.2.1 +version: 0.3.0 synopsis: Pipes for Noise-secured network connections. license: PublicDomain license-file: LICENSE @@ -10,7 +10,7 @@ category: Pipes, Cryptography build-type: Simple cabal-version: >=1.10 -tested-with: GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3 +tested-with: GHC == 7.10.3, GHC == 8.0.2 description: A set of pipes to secure network connections with the protocol. @@ -30,7 +30,13 @@ -- FLAGS flag hlint + description: Build hlint test +flag build-examples + description: Build example executables + default: False + manual: True + flag llvm default: False manual: True @@ -42,16 +48,37 @@ build-depends: base >=4.8 && <5, bytestring, - cacophony >=0.6, + cacophony >=0.7, pipes hs-source-dirs: src default-language: Haskell2010 exposed-modules: Pipes.Noise - ghc-options: -rtsopts -with-rtsopts=-N -Wall -fwarn-tabs + ghc-options: -Wall -fwarn-tabs if flag(llvm) ghc-options: -fllvm + +-------------------------------------------------------------------------------- +-- EXAMPLES + +executable loopback + default-language: Haskell2010 + hs-source-dirs: examples/loopback + main-is: Main.hs + + if flag(build-examples) + build-depends: + base >=4.8 && <5, + bytestring, + cacophony >=0.7, + lens, + pipes, + pipes-cacophony + else + buildable: False + + ghc-options: -threaded -O2 -rtsopts -with-rtsopts=-N -Wall -fwarn-tabs -------------------------------------------------------------------------------- -- TESTS diff --git a/src/Pipes/Noise.hs b/src/Pipes/Noise.hs --- a/src/Pipes/Noise.hs +++ b/src/Pipes/Noise.hs @@ -8,48 +8,61 @@ module Pipes.Noise ( -- * Types - MessagePipe, + InboundNoisePipe + , OutboundNoisePipe -- * Pipes - messageEncryptPipe, - messageDecryptPipe + , mkNoisePipes ) where -import Control.Concurrent.MVar (MVar, putMVar, takeMVar) -import Control.Monad (forever) +import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar) import Data.ByteString (ByteString) -import Pipes (Pipe, await, yield, lift) +import Pipes (Pipe, MonadIO, await, yield, liftIO) import Crypto.Noise.Cipher (Cipher) -import Crypto.Noise.Handshake -import Crypto.Noise.Types +import Crypto.Noise.DH (DH) +import Crypto.Noise.Hash (Hash) +import Crypto.Noise import Data.ByteArray.Extend --- | Message pipes transform ByteStrings. -type MessagePipe = Pipe ByteString ByteString - --- | Creates a new 'MessagePipe' exclusively for encryption. -messageEncryptPipe :: Cipher c - => MVar (SendingCipherState c) - -> MessagePipe IO r -messageEncryptPipe csmv = forever $ do - msg <- await +-- | Pipe used for inbound Noise messages. +type InboundNoisePipe = Pipe ByteString ScrubbedBytes - encState <- lift $ takeMVar csmv - let pt = Plaintext . bsToSB' $ msg - (ct, encState') = encryptPayload pt encState - lift $ putMVar csmv encState' +-- | Pipe used for outbound Noise messages. +type OutboundNoisePipe = Pipe ScrubbedBytes ByteString - yield ct +-- | Creates a pair of Pipes, the first used for inbound messages and the +-- second used for outbound messages. +mkNoisePipes :: (MonadIO m, Cipher c, DH d, Hash h) + => NoiseState c d h + -> IO (InboundNoisePipe m (Either NoiseException ()), OutboundNoisePipe m (Either NoiseException ())) +mkNoisePipes ns = do + nsmv <- liftIO . newMVar $ ns + return (inboundPipe nsmv, outboundPipe nsmv) --- | Creates a new 'MessagePipe' exclusively for decryption. -messageDecryptPipe :: Cipher c - => MVar (ReceivingCipherState c) - -> MessagePipe IO r -messageDecryptPipe csmv = forever $ do +inboundPipe :: (MonadIO m, Cipher c, DH d, Hash h) + => MVar (NoiseState c d h) + -> InboundNoisePipe m (Either NoiseException ()) +inboundPipe nsmv = do msg <- await - decState <- lift $ takeMVar csmv - let (Plaintext pt, decState') = decryptPayload msg decState - lift $ putMVar csmv decState' + ns <- liftIO . takeMVar $ nsmv + case readMessage ns msg of + Left e -> return . Left $ e + Right (pt, ns') -> do + liftIO . putMVar nsmv $ ns' + yield pt + inboundPipe nsmv - yield . sbToBS' $ pt +outboundPipe :: (MonadIO m, Cipher c, DH d, Hash h) + => MVar (NoiseState c d h) + -> OutboundNoisePipe m (Either NoiseException ()) +outboundPipe nsmv = do + msg <- await + + ns <- liftIO . takeMVar $ nsmv + case writeMessage ns msg of + Left e -> return . Left $ e + Right (ct, ns') -> do + liftIO . putMVar nsmv $ ns' + yield ct + outboundPipe nsmv