diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,7 +3,7 @@ [![Travis CI](https://img.shields.io/travis/aupiff/keccak.svg?label=Travis%20CI)](https://travis-ci.org/aupiff/keccak) -A pure haskell implementation of keccak. +A pure haskell implementation of the keccak family of hashes. ## Example usage @@ -26,12 +26,15 @@ ## Benchmarks -TODO +``` +stack bench +``` ## References -[Official Keccak Refeerence](https://keccak.team/files/Keccak-reference-3.0.pdf) +[Official Keccak Reference](https://keccak.team/files/Keccak-reference-3.0.pdf) [Specification summary](https://keccak.team/keccak_specs_summary.html) -[SHA-3 and The Hash Function Keccak (textbook chapter)](https://keccak.team/files/Keccak-reference-3.0.pdf) +[SHA-3 and The Hash Function Keccak (textbook +chapter)](https://pdfs.semanticscholar.org/8450/06456ff132a406444fa85aa7b5636266a8d0.pdf) diff --git a/benchs/Main.hs b/benchs/Main.hs new file mode 100644 --- /dev/null +++ b/benchs/Main.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Crypto.Hash.Keccak +import Test.Cryptonite +import qualified Data.ByteString as BS + +import Gauge + +stringsToHash :: [BS.ByteString] +stringsToHash = ["", "testing", "1234891237489127349817238497"] + +main = defaultMain + [ bench "keccak" $ nf (map keccak256) stringsToHash + , bench "cryptonite-keccak" $ nf (map cryptoniteKeccak') stringsToHash + ] diff --git a/keccak.cabal b/keccak.cabal --- a/keccak.cabal +++ b/keccak.cabal @@ -1,5 +1,5 @@ name: keccak -version: 0.1.0 +version: 0.1.1 synopsis: haskell keccak functions description: pure haskell implementation of keccak hash functions for use with ghc or ghcjs @@ -25,18 +25,39 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs + other-modules: Test.Cryptonite + Test.Parse.KAT build-depends: base , bytestring , base16-bytestring + , cryptonite , keccak , HUnit + , memory + , parsec , QuickCheck + , quickcheck-instances , test-framework , test-framework-hunit , test-framework-quickcheck2 + , text ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 +benchmark self + type: exitcode-stdio-1.0 + hs-source-dirs: benchs + , test + other-modules: Test.Cryptonite + default-language: Haskell2010 + main-is: Main.hs + build-depends: base + , bytestring + , cryptonite + , gauge + , keccak + , memory + source-repository head type: git - location: https://github.com/hasketh/keccak + location: https://github.com/aupiff/keccak diff --git a/src/Crypto/Hash/Keccak.hs b/src/Crypto/Hash/Keccak.hs --- a/src/Crypto/Hash/Keccak.hs +++ b/src/Crypto/Hash/Keccak.hs @@ -30,28 +30,69 @@ ] -paddingKeccak :: BS.ByteString -> [Word8] -paddingKeccak = multiratePadding 0x1 +paddingKeccak :: Int -> BS.ByteString -> [Word8] +paddingKeccak bitRateBytes = multiratePadding bitRateBytes 0x1 -paddingSha3 :: BS.ByteString -> [Word8] -paddingSha3 = multiratePadding 0x6 +paddingSha3 :: Int -> BS.ByteString -> [Word8] +paddingSha3 bitRateBytes = multiratePadding bitRateBytes 0x6 -multiratePadding :: Word -> BS.ByteString -> [Word8] -multiratePadding pad input = BS.unpack . BS.append input $ if padlen == 1 +multiratePadding :: Int -> Word8 -> BS.ByteString -> [Word8] +multiratePadding bitRateBytes padByte input = BS.unpack . BS.append input $ if padlen == 1 then BS.pack [0x81] - else BS.pack $ 0x01 : replicate (padlen - 2) 0x00 ++ [0x80] - where bitRateBytes = 136 - -- TODO: modulo bitRateBytes? + else BS.pack $ padByte : replicate (padlen - 2) 0x00 ++ [0x80] + where -- TODO: modulo bitRateBytes? usedBytes = BS.length input padlen = bitRateBytes - mod usedBytes bitRateBytes + +-- r (bitrate) = 576 +-- c (capacity) = 1024 +keccak512Rate :: Int +keccak512Rate = 576 + +keccak512 :: BS.ByteString -> BS.ByteString +keccak512 = squeeze 64 . absorb keccak512Rate + . toBlocks bitRateBytes + . paddingKeccak bitRateBytes + where bitRateBytes = div keccak512Rate 8 + + +-- r (bitrate) = 832 +-- c (capacity) = 768 +keccak384Rate :: Int +keccak384Rate = 832 + +keccak384 :: BS.ByteString -> BS.ByteString +keccak384 = squeeze 48 . absorb keccak384Rate + . toBlocks bitRateBytes + . paddingKeccak bitRateBytes + where bitRateBytes = div keccak384Rate 8 + -- r (bitrate) = 1088 -- c (capacity) = 512 +keccak256Rate :: Int +keccak256Rate = 1088 + keccak256 :: BS.ByteString -> BS.ByteString -keccak256 = squeeze 32 . absorb . toBlocks 136 . paddingKeccak +keccak256 = squeeze 32 . absorb keccak256Rate + . toBlocks bitRateBytes + . paddingKeccak bitRateBytes + where bitRateBytes = div keccak256Rate 8 +-- r (bitrate) = 1152 +-- c (capacity) = 448 +keccak224Rate :: Int +keccak224Rate = 1152 + +keccak224 :: BS.ByteString -> BS.ByteString +keccak224 = squeeze 28 . absorb keccak224Rate + . toBlocks bitRateBytes + . paddingKeccak bitRateBytes + where bitRateBytes = div keccak224Rate 8 + + -- Sized inputs to this? toBlocks :: Int -> [Word8] -> [[Word64]] toBlocks _ [] = [] @@ -68,18 +109,16 @@ -- for each block Pi in P -- S[x,y] = S[x,y] xor Pi[x+5*y], for (x,y) such that x+5*y < r/w -- S = Keccak-f[r+c](S) --- TODO support `input` larger than single block -absorb :: [[Word64]] -> State -absorb = foldl absorbBlock emptyState +absorb :: Int -> [[Word64]] -> State +absorb rate = foldl (absorbBlock rate) emptyState -absorbBlock :: State -> [Word64] -> State -absorbBlock state input = keccakF state' - where r = 1088 - w = 64 - state' = [ [ if x + 5 * y < div r w +absorbBlock :: Int -> State -> [Word64] -> State +absorbBlock rate state input = keccakF state' + where w = 64 -- lane size + state' = [ [ if x + 5 * y < div rate w then ((state !! x) !! y) `xor` (input !! (x + 5 * y)) else (state !! x) !! y - | y <- [0..4] ] + | y <- [0..4] ] | x <- [0..4] ] @@ -91,7 +130,6 @@ -- TODO handle longer outputs squeeze :: Int -> State -> BS.ByteString squeeze len = BS.pack . take len . stateToBytes - where comma = 44 stateToBytes :: State -> [Word8] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -3,12 +3,17 @@ import Crypto.Hash.Keccak import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as BS16 +import Data.Either +import Test.Cryptonite import Test.Framework (defaultMain, Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit (Assertion, assertEqual) -import Test.QuickCheck (Property, (==>)) +import Test.HUnit (Assertion, assertEqual, assertFailure) +import Test.Parse.KAT +import Test.QuickCheck ((==>), Property, withMaxSuccess) +import Test.QuickCheck.Instances.ByteString + main :: IO () main = defaultMain tests @@ -26,26 +31,38 @@ , testGroup "keccak256" [ testCase "hashing empty bytestring" keccak256EmptyTest , testCase "hashing string 'testing'" keccak256AsciiTest + , testProperty "extensionally equivalent to cryptonite-keccak" + (withMaxSuccess 3000 cryptoniteKeccak256_eq) ] + , testGroup "KAT" + [ testCase "ShortMsgKAT_224.txt" shortMsgKAT_224 + , testCase "LongMsgKAT_224.txt" longMsgKAT_224 + , testCase "ShortMsgKAT_256.txt" shortMsgKAT_256 + , testCase "LongMsgKAT_256.txt" longMsgKAT_256 + , testCase "ShortMsgKAT_384.txt" shortMsgKAT_384 + , testCase "LongMsgKAT_384.txt" longMsgKAT_384 + , testCase "ShortMsgKAT_512.txt" shortMsgKAT_512 + , testCase "LongMsgKAT_512.txt" longMsgKAT_512 + ] ] keccakEmptyPaddingTest :: Assertion -keccakEmptyPaddingTest = assertEqual "Pads empty string properly" zeroPadding (paddingKeccak "") +keccakEmptyPaddingTest = assertEqual "Pads empty string properly" zeroPadding (paddingKeccak 136 "") where zeroPadding = [1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 128] keccakAsciiPaddingTest :: Assertion -keccakAsciiPaddingTest = assertEqual "Pads ascii string properly" asciiPadding (paddingKeccak "testing") +keccakAsciiPaddingTest = assertEqual "Pads ascii string properly" asciiPadding (paddingKeccak 136 "testing") where asciiPadding = [116, 101, 115, 116, 105, 110, 103, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 128] keccakEmptyAbsorbtionTest :: Assertion -keccakEmptyAbsorbtionTest = assertEqual "Absorbs empty input properly" endState (absorb . toBlocks 136 $ paddingKeccak "") +keccakEmptyAbsorbtionTest = assertEqual "Absorbs empty input properly" endState (absorb keccak256Rate . toBlocks 136 $ paddingKeccak 136 "") where endState = [[4333579421379646149,14671339323370021561,4391692840257016808,16970298442240338249,16062291397582171322],[13836122230913597074,2243375101132795228,4309499098775122448,1971761234120675839,1601982631079003425],[4262519377828905189,9371364203318886753,13438072403645551266,450719451514497906,7734681229251997073],[8116759062988257915,9347994793612953298,18018124564071650747,18340686150147091359,13256946727218518206],[8406387447366859581,12814238161780307547,4323130096954625545,11254645818134300982,11816912122432958423]] keccakAsciiAbsorbtionTest :: Assertion -keccakAsciiAbsorbtionTest = assertEqual "Absorbs ascii input properly" asciiState (absorb . toBlocks 136 $ paddingKeccak "testing") +keccakAsciiAbsorbtionTest = assertEqual "Absorbs ascii input properly" asciiState (absorb keccak256Rate . toBlocks 136 $ paddingKeccak 136 "testing") where asciiState = [[5741044927781148255,5536040307487716601,11084357000576311707,12707954408119767660,8319093435246931416],[253595265147670677,7606140838194786578,2366244087054482559,18181979956023419548,7691975034864958586],[10448875313496118154,17475093054141481980,11669704621260022411,9601734410265320743,13113298532289803684],[151888593866888543,4052828971212897447,7607297586066738160,15654769812205594072,16061863611318168517],[3465997019864229635,12358594370410885724,17971813471771339249,7394790340576097786,5735185612101350050]] @@ -55,3 +72,41 @@ keccak256AsciiTest :: Assertion keccak256AsciiTest = assertEqual "Hashes ascii string" ("5f16f4c7f149ac4f9510d9cf8cf384038ad348b3bcdc01915f95de12df9d1b02" :: BS.ByteString) (BS16.encode $ keccak256 "testing") + +cryptoniteKeccak256_eq :: BS.ByteString -> Bool +cryptoniteKeccak256_eq xs = + keccak256 xs == cryptoniteKeccak' xs + + +knownAnswerTestAssertion :: FilePath -> (BS.ByteString -> BS.ByteString) -> Assertion +knownAnswerTestAssertion testFile hashFunction = do + katsE <- parseFromFile parseTestFile testFile + kats <- either (assertFailure . show) pure katsE + mapM_ runKat kats + where runKat (KAT l m d) = if l `mod` 8 == 0 + then assertEqual "Bad digest" (hashFunction $ BS.take l m) d + else assertEqual "Non-byte lenght msg" True True + +shortMsgKAT_224 :: Assertion +shortMsgKAT_224 = knownAnswerTestAssertion "test/KAT_MCT/ShortMsgKAT_224.txt" keccak224 + +longMsgKAT_224 :: Assertion +longMsgKAT_224 = knownAnswerTestAssertion "test/KAT_MCT/LongMsgKAT_224.txt" keccak224 + +shortMsgKAT_256 :: Assertion +shortMsgKAT_256 = knownAnswerTestAssertion "test/KAT_MCT/ShortMsgKAT_256.txt" keccak256 + +longMsgKAT_256 :: Assertion +longMsgKAT_256 = knownAnswerTestAssertion "test/KAT_MCT/LongMsgKAT_256.txt" keccak256 + +shortMsgKAT_384 :: Assertion +shortMsgKAT_384 = knownAnswerTestAssertion "test/KAT_MCT/ShortMsgKAT_384.txt" keccak384 + +longMsgKAT_384 :: Assertion +longMsgKAT_384 = knownAnswerTestAssertion "test/KAT_MCT/LongMsgKAT_384.txt" keccak384 + +shortMsgKAT_512 :: Assertion +shortMsgKAT_512 = knownAnswerTestAssertion "test/KAT_MCT/ShortMsgKAT_512.txt" keccak512 + +longMsgKAT_512 :: Assertion +longMsgKAT_512 = knownAnswerTestAssertion "test/KAT_MCT/LongMsgKAT_512.txt" keccak512 diff --git a/test/Test/Cryptonite.hs b/test/Test/Cryptonite.hs new file mode 100644 --- /dev/null +++ b/test/Test/Cryptonite.hs @@ -0,0 +1,11 @@ +module Test.Cryptonite where + +import Crypto.Hash (Digest, Keccak_256, hash) +import Data.ByteArray (convert) +import qualified Data.ByteString as BS + +cryptoniteKeccak' :: BS.ByteString -> BS.ByteString +cryptoniteKeccak' = convert . cryptoniteKeccak + +cryptoniteKeccak :: BS.ByteString -> Digest Keccak_256 +cryptoniteKeccak = hash diff --git a/test/Test/Parse/KAT.hs b/test/Test/Parse/KAT.hs new file mode 100644 --- /dev/null +++ b/test/Test/Parse/KAT.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Parse.KAT where + +import Control.Monad (void) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as BS16 +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Text.IO as T +import Text.Parsec +import Text.Parsec.Text +import Text.Parsec.Expr + +type TestFile = [KAT] + +data KAT = KAT { length :: Int + , message :: BS.ByteString + , digest :: BS.ByteString + } deriving Show + +parseTestFile :: Parser TestFile +parseTestFile = skipMany (commentLine <|> blankLine) *> many1 parseKat + +commentLine :: Parser () +commentLine = void $ char '#' *> manyTill anyChar endOfLine + +blankLine :: Parser () +blankLine = void endOfLine + +parseKat :: Parser KAT +parseKat = do len <- string "Len = " *> many1 digit <* endOfLine + msg <- string "Msg = " *> many1 hexDigit <* endOfLine + digest <- string "MD = " *> many1 hexDigit <* endOfLine + skipMany (commentLine <|> blankLine) + let parsedLen = read len + pure $ KAT parsedLen (BS.take parsedLen $ bytesDecode msg) + (bytesDecode digest) + +bytesDecode :: String -> BS.ByteString +bytesDecode = fst . BS16.decode . T.encodeUtf8 . T.pack + +parseFromFile :: Parsec T.Text () a -> FilePath -> IO (Either ParseError a) +parseFromFile p fname = do + input <- T.readFile fname + return (runParser p () fname input)