diff --git a/example/DecrypterSimple.hs b/example/DecrypterSimple.hs new file mode 100644 --- /dev/null +++ b/example/DecrypterSimple.hs @@ -0,0 +1,17 @@ +module Main where + +import Crypto.RNCryptor.V3.Decrypt +import System.Environment +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString as BIO +import Control.Exception (throwIO) + +main :: IO () +main = do + args <- getArgs + case args of + file:key:_ -> do + input <- BIO.readFile file + case decrypt input (B.pack key) of + Left err -> throwIO $ userError (show err) + Right txt -> BIO.writeFile "/dev/stdout" txt diff --git a/rncryptor.cabal b/rncryptor.cabal --- a/rncryptor.cabal +++ b/rncryptor.cabal @@ -1,5 +1,5 @@ name: rncryptor -version: 0.3.0.2 +version: 0.4.0.0 synopsis: Haskell implementation of the RNCryptor file format description: Pure Haskell implementation of the RNCrytor spec. license: MIT @@ -8,7 +8,7 @@ maintainer: alfredo.dinapoli@gmail.com category: Network build-type: Simple -tested-with: GHC == 7.6, GHC == 7.8 +tested-with: GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.4, GHC == 9.6.6 cabal-version: >=1.10 flag fastpbkdf2 @@ -83,6 +83,22 @@ example main-is: StreamingDecrypter.hs + default-language: + Haskell2010 + ghc-options: + -funbox-strict-fields + +executable rncryptor-decrypt-simple + build-depends: + base + , bytestring + , cryptonite >= 0.15 + , io-streams + , rncryptor -any + hs-source-dirs: + example + main-is: + DecrypterSimple.hs default-language: Haskell2010 ghc-options: diff --git a/src/Crypto/RNCryptor/Types.hs b/src/Crypto/RNCryptor/Types.hs --- a/src/Crypto/RNCryptor/Types.hs +++ b/src/Crypto/RNCryptor/Types.hs @@ -39,27 +39,43 @@ import Crypto.MAC.HMAC (Context, initialize, hmac) import qualified Crypto.MAC.HMAC as Crypto import Data.ByteArray (ByteArray, convert) -import Data.ByteString (cons, ByteString, unpack) +import Data.ByteString (cons, ByteString, unpack, intersperse) import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString as B import Data.Monoid import Data.Typeable import Data.Word import System.Random import Test.QuickCheck (Arbitrary(..), vector) +import Text.Printf (printf) +import qualified Data.List as L data RNCryptorException = - InvalidHMACException !ByteString !ByteString - -- ^ HMAC validation failed. First parameter is the untrusted hmac, the - -- second the computed one. + InvalidHMACException !ByteString !ByteString + -- ^ HMAC validation failed. First parameter is the untrusted hmac, the + -- second the computed one. + | TruncatedStream !Int + -- ^ The stream ended before a whole trailer (at least one cipher block + -- plus the 32-byte HMAC, block aligned) could be read. Carries the number + -- of trailing bytes that were available. deriving (Typeable, Eq) instance Show RNCryptorException where show (InvalidHMACException untrusted computed) = - "InvalidHMACException: Untrusted HMAC was " <> show (unpack untrusted) - <> ", but the computed one is " <> show (unpack computed) <> "." + "InvalidHMACException: Untrusted HMAC was " <> showHex untrusted + <> "(" <> show (B.length untrusted) <> " bytes), " + <> " but the computed one is " + <> showHex computed + <> "(" <> show (B.length computed) <> " bytes)." + show (TruncatedStream n) = + "TruncatedStream: input ended with " <> show n <> " trailing bytes, " + <> "need at least " <> show (blockSize + 32) <> " and block aligned before the HMAC." instance Exception RNCryptorException + +showHex :: B.ByteString -> String +showHex = L.unwords . map (printf "%02x") . B.unpack type Password = ByteString type HMAC = ByteString diff --git a/src/Crypto/RNCryptor/V3/Decrypt.hs b/src/Crypto/RNCryptor/V3/Decrypt.hs --- a/src/Crypto/RNCryptor/V3/Decrypt.hs +++ b/src/Crypto/RNCryptor/V3/Decrypt.hs @@ -1,14 +1,20 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use if" #-} module Crypto.RNCryptor.V3.Decrypt ( parseHeader , decrypt , decryptBlock , decryptStream + , decryptStreamWith + , decryptStreamLenient + , OnHMACFailure(..) ) where +import Control.Exception (throwIO, Exception (..)) +import Control.Monad (unless) import Control.Monad.State -import Control.Exception (throwIO) import Crypto.Cipher.AES (AES256) import Crypto.Cipher.Types (IV, makeIV, BlockCipher, cbcDecrypt) import Crypto.MAC.HMAC (update, finalize) @@ -17,11 +23,13 @@ import Data.Bits (xor, (.|.)) import Data.ByteArray (convert) import Data.ByteString (ByteString) -import qualified Data.ByteString as B import Data.Foldable import Data.Maybe (fromMaybe) import Data.Monoid import Data.Word +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) +import qualified Data.ByteString as B import qualified System.IO.Streams as S -------------------------------------------------------------------------------- @@ -91,9 +99,14 @@ -- data = data[:-bord(data[-1])] -- https://github.com/RNCryptor/RNCryptor-python/blob/master/RNCryptor.py#L69 removePaddingSymbols :: ByteString -> ByteString -removePaddingSymbols input = - let lastWord = B.last input - in B.take (B.length input - fromEnum lastWord) input +removePaddingSymbols input + | B.null input = input + | otherwise = + let lastByte = B.last input + padLength = fromEnum lastByte + in if padLength <= 16 && padLength <= B.length input + then B.take (B.length input - padLength) input + else input -- Invalid padding byte, return original input -------------------------------------------------------------------------------- decryptBytes :: AES256 -> ByteString -> ByteString -> ByteString @@ -150,25 +163,68 @@ True -> Right (removePaddingSymbols clearText) False -> Left (InvalidHMACException msgHMAC hmac) + +data OnHMACFailure + = OHF_abort + -- | Not recommended for production systems, but useful for debugging. + | OHF_emit_warning + | OHF_emit_warning_exit_failure + -------------------------------------------------------------------------------- -- | Efficiently decrypts an incoming stream of bytes. -decryptStream :: ByteString - -- ^ The user key (e.g. password) - -> S.InputStream ByteString - -- ^ The input source (mostly likely stdin) - -> S.OutputStream ByteString - -- ^ The output source (mostly likely stdout) - -> IO () -decryptStream userKey inS outS = do +decryptStreamWith :: OnHMACFailure + -> ByteString + -- ^ The user key (e.g. password) + -> S.InputStream ByteString + -- ^ The input source (mostly likely stdin) + -> S.OutputStream ByteString + -- ^ The output source (mostly likely stdout) + -> IO () +decryptStreamWith onInvalidHMAC userKey inS outS = do rawHdr <- S.readExactly 34 inS let hdr = parseHeader rawHdr ctx = newRNCryptorContext userKey hdr ctx' = ctx { ctxHMACCtx = update (ctxHMACCtx ctx) rawHdr } - processStream ctx' inS outS decryptBlock finaliseDecryption + -- Hold back the last cipher block (PKCS#7 padding lives there) plus the HMAC. + processStream (blockSize + 32) ctx' inS outS decryptBlock finaliseDecryption where - finaliseDecryption lastBlock ctx = do - let (cipherText, msgHMAC) = B.splitAt (B.length lastBlock - 32) lastBlock + finaliseDecryption trailer ctx = do + let trailerLen = B.length trailer + unless (trailerLen >= blockSize + 32 && (trailerLen - 32) `rem` blockSize == 0) $ + throwIO (TruncatedStream trailerLen) + let (cipherText, msgHMAC) = B.splitAt (trailerLen - 32) trailer (ctx', clearText) = decryptBlock ctx cipherText hmac = convert $ finalize (ctxHMACCtx ctx') - unless (consistentTimeEqual msgHMAC hmac) (throwIO $ InvalidHMACException msgHMAC hmac) S.write (Just $ removePaddingSymbols clearText) outS + let invalidHMacEx = InvalidHMACException msgHMAC hmac + case consistentTimeEqual msgHMAC hmac of + True -> pure () + False -> case onInvalidHMAC of + OHF_abort -> throwIO invalidHMacEx + OHF_emit_warning -> do + hPutStrLn stderr (displayException invalidHMacEx) + OHF_emit_warning_exit_failure -> do + exitFailure + +-------------------------------------------------------------------------------- +-- | Efficiently decrypts an incoming stream of bytes. +decryptStream :: ByteString + -- ^ The user key (e.g. password) + -> S.InputStream ByteString + -- ^ The input source (mostly likely stdin) + -> S.OutputStream ByteString + -- ^ The output source (mostly likely stdout) + -> IO () +decryptStream = decryptStreamWith OHF_abort + +-------------------------------------------------------------------------------- +-- | Efficiently decrypts an incoming stream of bytes, not failing if the +-- stream fails HMAC validation. +decryptStreamLenient :: ByteString + -- ^ The user key (e.g. password) + -> S.InputStream ByteString + -- ^ The input source (mostly likely stdin) + -> S.OutputStream ByteString + -- ^ The output source (mostly likely stdout) + -> IO () +decryptStreamLenient = decryptStreamWith OHF_emit_warning diff --git a/src/Crypto/RNCryptor/V3/Encrypt.hs b/src/Crypto/RNCryptor/V3/Encrypt.hs --- a/src/Crypto/RNCryptor/V3/Encrypt.hs +++ b/src/Crypto/RNCryptor/V3/Encrypt.hs @@ -63,7 +63,8 @@ -> IO () encryptStreamWithContext ctx inS outS = do S.write (Just (renderRNCryptorHeader $ ctxHeader ctx)) outS - processStream ctx inS outS encryptBlock finaliseEncryption + -- Nothing to hold back: the finaliser pads whatever tail is left. + processStream 0 ctx inS outS encryptBlock finaliseEncryption where finaliseEncryption lastBlock lastCtx = do let (ctx', cipherText) = encryptBlock lastCtx (lastBlock <> pkcs7Padding blockSize (B.length lastBlock)) diff --git a/src/Crypto/RNCryptor/V3/Stream.hs b/src/Crypto/RNCryptor/V3/Stream.hs --- a/src/Crypto/RNCryptor/V3/Stream.hs +++ b/src/Crypto/RNCryptor/V3/Stream.hs @@ -1,29 +1,21 @@ {-# LANGUAGE BangPatterns #-} module Crypto.RNCryptor.V3.Stream ( processStream - , StreamingState(..) ) where +import Crypto.RNCryptor.Types 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 --------------------------------------------------------------------------------- --- | The 'StreamingState' the streamer can be at. This is needed to drive the --- computation as well as reading leftovers unread back in case we need to --- chop the buffer read, if not multiple of the 'blockSize'. -data StreamingState = - Continue - | FetchLeftOver !Int - | DrainSource deriving (Show, Eq) - --------------------------------------------------------------------------------- --- | Efficiently transform an incoming stream of bytes. -processStream :: RNCryptorContext +-- | Drive a block transform over an input stream in constant memory. Whole +-- blocks are transformed and written as soon as they are available; the last +-- 'holdBack' bytes are never transformed here and are handed to the finaliser +-- at end of input. +processStream :: Int + -- ^ How many trailing bytes the finaliser needs to see + -- untouched (decrypt: last block + HMAC, encrypt: 0). + -> RNCryptorContext -- ^ The RNCryptor context for this operation -> S.InputStream ByteString -- ^ The input source (mostly likely stdin) @@ -34,38 +26,24 @@ -> (ByteString -> RNCryptorContext -> IO ()) -- ^ The finaliser -> IO () -processStream context inS outS blockFn finaliser = go Continue mempty context +processStream holdBack context inS outS applyToBlock finaliser = go B.empty 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 - -- If I'm here, it means I can safely process this chunk - 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 + -- 'carry' stays below holdBack + blockSize bytes: anything beyond that is + -- a whole block and gets transformed on the read that completes it. That + -- bound is what keeps memory independent of input size and of how the + -- input is chunked. The only end-of-input signal is 'S.read' returning + -- 'Nothing'; no peeking, no guessing from chunk sizes. + go !carry !ctx = do + mchunk <- S.read inS + case mchunk of + Nothing -> finaliser carry ctx + Just chunk -> do + let buf = carry <> chunk + processable = ((B.length buf - holdBack) `div` blockSize) * blockSize + if processable <= 0 + then go buf ctx + else do + let (blocks, rest) = B.splitAt processable buf + (ctx', out) = applyToBlock ctx blocks + S.write (Just out) outS + go rest ctx' diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -26,8 +26,13 @@ , testCase "Multibyte password" Pwd.multibytePassword , testCase "Longer text and password" Pwd.longerTextAndPassword ] + , testGroup "Streaming with chunked input" [ + testCase "one-byte chunks" testOneByteChunks + , testCase "HMAC as final chunk" testHMACAsFinalChunk + ] , withQuickCheckDepth "RNCryptor properties" 100 [ testProperty "encrypt/decrypt roundtrip" testEncryptDecryptRoundtrip , testProperty "encrypt/decrypt streaming roundtrip" testStreamingEncryptDecryptRoundtrip + , testProperty "encrypt/decrypt chunked streaming roundtrip" testChunkedStreamingRoundtrip ] ] diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -72,3 +72,64 @@ ] let swiftPassword = B.pack [112,97,115,115,119,111,114,100] decrypt swiftEncrypted swiftPassword @=? Right "01" + +-------------------------------------------------------------------------------- +-- Streaming with arbitrary chunking. A pipe hands io-streams whatever is in +-- the buffer at read time, down to a single byte, so the streaming code must +-- produce the same output for every way of cutting the input into chunks. + +-- | Cut the input into chunks of the given sizes; whatever the sizes don't +-- cover becomes one final chunk. Non-positive sizes are skipped. +chunksOf :: [Int] -> B.ByteString -> [B.ByteString] +chunksOf _ bs | B.null bs = [] +chunksOf [] bs = [bs] +chunksOf (n:ns) bs + | n <= 0 = chunksOf ns bs + | otherwise = let (h, t) = B.splitAt n bs in h : chunksOf ns t + +-- | Chunk sizes biased towards slivers smaller than a block + HMAC. +newtype ChunkSizes = ChunkSizes [Int] deriving Show + +instance Arbitrary ChunkSizes where + arbitrary = ChunkSizes <$> listOf (frequency [(4, choose (1, 48)), (1, choose (49, 4096))]) + shrink (ChunkSizes xs) = ChunkSizes <$> shrink xs + +chunkedRoundTrip :: B.ByteString -> [Int] -> [Int] -> B.ByteString -> IO B.ByteString +chunkedRoundTrip key encChunks decChunks plainText = do + plainTextInS <- fromList (chunksOf encChunks plainText) + (cipherTextOutS, flushCipherText) <- listOutputStream + encryptStream key plainTextInS cipherTextOutS + cipherText <- B.concat <$> flushCipherText + cipherTextInS <- fromList (chunksOf decChunks cipherText) + (plainTextOutS, flushPlainText) <- listOutputStream + decryptStream key cipherTextInS plainTextOutS + B.concat <$> flushPlainText + +testChunkedStreamingRoundtrip :: UserInput -> ChunkSizes -> ChunkSizes -> ArbByteString -> Property +testChunkedStreamingRoundtrip pwd (ChunkSizes encChunks) (ChunkSizes decChunks) input = + B.length (unInput pwd) > 0 ==> M.monadicIO $ do + let plainText = fromABS input + input' <- M.run (chunkedRoundTrip (unInput pwd) encChunks decChunks plainText) + M.assert (plainText == input') + +testOneByteChunks :: Assertion +testOneByteChunks = do + let plainText = C8.pack (take 1000 (cycle ['a'..'z'])) + ones = repeat 1 + input' <- chunkedRoundTrip "password" ones ones plainText + input' @?= plainText + +-- The final chunk is exactly the 32-byte HMAC, so the last cipher block +-- arrives in the chunk before it. +testHMACAsFinalChunk :: Assertion +testHMACAsFinalChunk = do + let plainText = C8.pack (take 1000 (cycle ['a'..'z'])) + plainTextInS <- fromByteString plainText + (cipherTextOutS, flushCipherText) <- listOutputStream + encryptStream "password" plainTextInS cipherTextOutS + cipherText <- B.concat <$> flushCipherText + cipherTextInS <- fromList (chunksOf [B.length cipherText - 32] cipherText) + (plainTextOutS, flushPlainText) <- listOutputStream + decryptStream "password" cipherTextInS plainTextOutS + input' <- B.concat <$> flushPlainText + input' @?= plainText