{-# LANGUAGE OverloadedStrings #-}
----------------------------------------------------------------
-- |
-- Module : Pipes.Noise
-- Maintainer : John Galt <jgalt@centromere.net>
-- Stability : experimental
-- Portability : POSIX
module Pipes.Noise
( -- * Types
InboundNoisePipe
, OutboundNoisePipe
-- * Pipes
, mkNoisePipes
) where
import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar)
import Data.ByteString (ByteString)
import Pipes (Pipe, MonadIO, await, yield, liftIO)
import Crypto.Noise.Cipher (Cipher)
import Crypto.Noise.DH (DH)
import Crypto.Noise.Hash (Hash)
import Crypto.Noise
import Data.ByteArray.Extend
-- | Pipe used for inbound Noise messages.
type InboundNoisePipe = Pipe ByteString ScrubbedBytes
-- | Pipe used for outbound Noise messages.
type OutboundNoisePipe = Pipe ScrubbedBytes ByteString
-- | 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)
inboundPipe :: (MonadIO m, Cipher c, DH d, Hash h)
=> MVar (NoiseState c d h)
-> InboundNoisePipe m (Either NoiseException ())
inboundPipe nsmv = do
msg <- await
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
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