{-# LANGUAGE BangPatterns #-}
module Crypto.RNCryptor.V3.Stream
( processStream
, StreamingState(..)
) where
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.Word
import Control.Monad.State
import Crypto.RNCryptor.Types
import Data.Monoid
import qualified System.IO.Streams as S
data StreamingState =
Continue
| FetchLeftOver !Int
| DrainSource deriving (Show, Eq)
processStream :: RNCryptorContext
-> S.InputStream ByteString
-> S.OutputStream ByteString
-> (RNCryptorContext -> ByteString -> (RNCryptorContext, ByteString))
-> (ByteString -> RNCryptorContext -> IO ())
-> IO ()
processStream context inS outS blockFn finaliser = go Continue mempty context
where
slack input = let bsL = B.length input in (bsL, bsL `mod` blockSize)
go :: StreamingState -> ByteString -> RNCryptorContext -> IO ()
go dc !iBuffer ctx = do
nextChunk <- case dc of
FetchLeftOver size -> do
lo <- S.readExactly size inS
p <- S.read inS
return $ fmap (mappend lo) p
_ -> S.read inS
case nextChunk of
Nothing -> finaliser iBuffer ctx
(Just v) -> do
let (sz, sl) = slack v
case dc of
DrainSource -> go DrainSource (iBuffer <> v) ctx
_ -> do
whatsNext <- S.peek inS
case whatsNext of
Nothing -> finaliser (iBuffer <> v) ctx
Just nt ->
case sz + B.length nt < 4096 of
True -> go DrainSource (iBuffer <> v) ctx
False -> do
let (toProcess, rest) = B.splitAt (sz - sl) v
let (newCtx, res) = blockFn ctx toProcess
S.write (Just res) outS
case sl == 0 of
False -> do
S.unRead rest inS
go (FetchLeftOver sl) iBuffer newCtx
True -> go Continue iBuffer newCtx