From 676eca28e802b602b399b2965ffb15cb8a7a42ae Mon Sep 17 00:00:00 2001 From: Benjamin Barenblat Date: Fri, 26 Jan 2018 21:28:18 -0500 Subject: Implement SHA-1 --- btls.cabal | 5 +- src/Data/Digest/Sha1.hsc | 38 ++++++++++++++ tests/Data/Digest/HashTests.hs | 51 +++++++++++++++++++ tests/Data/Digest/Sha1Tests.hs | 110 +++++++++++++++++++++++++++++++++++++++++ tests/Data/Digest/Sha2Tests.hs | 42 ++-------------- tests/Tests.hs | 5 +- 6 files changed, 210 insertions(+), 41 deletions(-) create mode 100644 src/Data/Digest/Sha1.hsc create mode 100644 tests/Data/Digest/HashTests.hs create mode 100644 tests/Data/Digest/Sha1Tests.hs diff --git a/btls.cabal b/btls.cabal index fc91ad1..7008631 100644 --- a/btls.cabal +++ b/btls.cabal @@ -33,6 +33,7 @@ library -Wno-safe -Wno-unsafe -optl-Wl,-z,relro -optl-Wl,-z,now -optl-Wl,-s exposed-modules: Data.Digest + , Data.Digest.Sha1 , Data.Digest.Sha2 other-modules: Cleanse , Data.Digest.Internal @@ -56,7 +57,9 @@ test-suite tests -Wno-safe -Wno-unsafe -optl-Wl,-z,relro -optl-Wl,-z,now -optl-Wl,-s main-is: Tests.hs - other-modules: Data.Digest.Sha2Tests + other-modules: Data.Digest.HashTests + , Data.Digest.Sha1Tests + , Data.Digest.Sha2Tests build-depends: base >=4.9 && <4.10 , btls , bytestring >=0.10 && <0.11 diff --git a/src/Data/Digest/Sha1.hsc b/src/Data/Digest/Sha1.hsc new file mode 100644 index 0000000..6ac4c34 --- /dev/null +++ b/src/Data/Digest/Sha1.hsc @@ -0,0 +1,38 @@ +{-# LANGUAGE CApiFFI #-} +{-# OPTIONS_GHC -Wno-missing-methods #-} + +module Data.Digest.Sha1 + ( sha1 + ) where + +import Data.ByteString.Lazy (ByteString) +import Foreign (Ptr, Storable(alignment, sizeOf)) +import Foreign.C.Types + +import Data.Digest.Internal + +#include + +data ShaCtx + +instance Storable ShaCtx where + sizeOf _ = #size SHA_CTX + alignment _ = #alignment SHA_CTX + +foreign import capi "openssl/sha.h value SHA_DIGEST_LENGTH" + shaDigestLength :: CSize + +foreign import ccall "openssl/sha.h SHA1_Init" + sha1Init :: Ptr ShaCtx -> IO CInt + +foreign import ccall "openssl/sha.h SHA1_Update" + sha1Update :: Ptr ShaCtx -> Ptr a -> CSize -> IO CInt + +foreign import ccall "openssl/sha.h SHA1_Final" + sha1Final :: Ptr CUChar -> Ptr ShaCtx -> IO CInt + +sha1Algo :: Algo +sha1Algo = Algo shaDigestLength sha1Init sha1Update sha1Final + +sha1 :: ByteString -> Digest +sha1 = hash sha1Algo diff --git a/tests/Data/Digest/HashTests.hs b/tests/Data/Digest/HashTests.hs new file mode 100644 index 0000000..0691bf4 --- /dev/null +++ b/tests/Data/Digest/HashTests.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Digest.HashTests + ( goTestCase + , testAgainstCoreutils + , testAgainstOpenssl + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import System.IO (hClose, hGetContents, hSetBinaryMode) +import System.Process + (CreateProcess(std_in, std_out), StdStream(CreatePipe), + createProcess_, proc) +import qualified Test.SmallCheck.Series.ByteString + as ByteString.Series +import Test.Tasty (TestTree) +import Test.Tasty.HUnit ((@?=), testCase) +import Test.Tasty.SmallCheck (Property, monadic, over) + +goTestCase :: (ByteString -> String) -> (String, ByteString) -> TestTree +goTestCase f (output, input) = testCase description (f input @?= output) + where + description = + let (x, y) = ByteString.splitAt 11 input + in show (x `ByteString.append` if ByteString.null y then "" else "...") + +testAgainstCoreutils :: (ByteString -> String) -> FilePath -> Property IO +testAgainstCoreutils f prog = + over ByteString.Series.enumW8s $ \s -> + monadic $ do + theirs <- runExternal (proc prog ["-b"]) s + return (f s == head (words theirs)) + +-- | Runs an external hashing command with the specified standard input. Assumes +-- that the process will exit when its standard input is closed. +runExternal :: CreateProcess -> ByteString -> IO String +runExternal p s = do + (Just stdin, Just stdout, _, _) <- + createProcess_ "runExternal" (p {std_in = CreatePipe, std_out = CreatePipe}) + hSetBinaryMode stdin True + ByteString.hPut stdin s + hClose stdin -- causes process to exit + hGetContents stdout + +testAgainstOpenssl :: (ByteString -> String) -> String -> Property IO +testAgainstOpenssl f flag = + over ByteString.Series.enumW8s $ \s -> + monadic $ do + theirs <- runExternal (proc "openssl" ["dgst", '-' : flag]) s + return (f s == words theirs !! 1) diff --git a/tests/Data/Digest/Sha1Tests.hs b/tests/Data/Digest/Sha1Tests.hs new file mode 100644 index 0000000..3d06e5d --- /dev/null +++ b/tests/Data/Digest/Sha1Tests.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Digest.Sha1Tests + ( tests + ) where + +import qualified Data.ByteString.Lazy as ByteString.Lazy +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@?=), testCase) +import Test.Tasty.SmallCheck (testProperty) + +import Data.Digest.HashTests + (goTestCase, testAgainstCoreutils, testAgainstOpenssl) +import Data.Digest.Sha1 + +tests :: TestTree +tests = + testGroup + "Data.Digest.Sha1" + [ testNistExamples + , testGoExamples + , testCoreutilsConformance + , testOpensslConformance + ] + + +-- | SHA-1 example vectors from +-- https://csrc.nist.gov/projects/cryptographic-standards-and-guidelines/example-values. +testNistExamples = + testGroup + "NIST examples" + [ testCase "one-block" $ + sha1sum "abc" @?= "a9993e364706816aba3e25717850c26c9cd0d89d" + , testCase "two-block" $ + sha1sum "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" @?= + "84983e441c3bd26ebaae4aa1f95129e5e54670f1" + ] + +-- | Test vectors used to test the Go SHA-1 implementation. +testGoExamples = + testGroup "Go tests" $ + map + (goTestCase sha1sum) + [ ( "76245dbf96f661bd221046197ab8b9f063f11bad" + , "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\n") + , ("da39a3ee5e6b4b0d3255bfef95601890afd80709", "") + , ("86f7e437faa5a7fce15d1ddcb9eaeaea377667b8", "a") + , ("da23614e02469a0d7c7bd1bdab5c9c474b1904dc", "ab") + , ("a9993e364706816aba3e25717850c26c9cd0d89d", "abc") + , ("81fe8bfe87576c3ecb22426f8e57847382917acf", "abcd") + , ("03de6c570bfe24bfc328ccd7ca46b76eadaf4334", "abcde") + , ("1f8ac10f23c5b5bc1167bda84b833e5c057a77d2", "abcdef") + , ("2fb5e13419fc89246865e7a324f476ec624e8740", "abcdefg") + , ("425af12a0743502b322e93a015bcf868e324d56a", "abcdefgh") + , ("c63b19f1e4c8b5f76b25c49b8b87f57d8e4872a1", "abcdefghi") + , ("d68c19a0a345b7eab78d5e11e991c026ec60db63", "abcdefghij") + , ( "ebf81ddcbe5bf13aaabdc4d65354fdf2044f38a7" + , "Discard medicine more than two years old.") + , ( "e5dea09392dd886ca63531aaa00571dc07554bb6" + , "He who has a shady past knows that nice guys finish last.") + , ( "45988f7234467b94e3e9494434c96ee3609d8f8f" + , "I wouldn't marry him with a ten foot pole.") + , ( "55dee037eb7460d5a692d1ce11330b260e40c988" + , "Free! Free!/A trip/to Mars/for 900/empty jars/Burma Shave") + , ( "b7bc5fb91080c7de6b582ea281f8a396d7c0aee8" + , "The days of the digital watch are numbered. -Tom Stoppard") + , ( "c3aed9358f7c77f523afe86135f06b95b3999797" + , "Nepal premier won't resign.") + , ( "6e29d302bf6e3a5e4305ff318d983197d6906bb9" + , "For every action there is an equal and opposite government program.") + , ( "597f6a540010f94c15d71806a99a2c8710e747bd" + , "His money is twice tainted: 'taint yours and 'taint mine.") + , ( "6859733b2590a8a091cecf50086febc5ceef1e80" + , "There is no reason for any individual to have a computer in their home. -Ken Olsen, 1977") + , ( "514b2630ec089b8aee18795fc0cf1f4860cdacad" + , "It's a tiny change to the code and not completely disgusting. - Bob Manchek") + , ("c5ca0d4a7b6676fc7aa72caa41cc3d5df567ed69", "size: a.out: bad magic") + , ( "74c51fa9a04eadc8c1bbeaa7fc442f834b90a00a" + , "The major problem is with sendmail. -Mark Horton") + , ( "0b4c4ce5f52c3ad2821852a8dc00217fa18b8b66" + , "Give me a rock, paper and scissors and I will move the world. CCFestoon") + , ( "3ae7937dd790315beb0f48330e8642237c61550a" + , "If the enemy is within range, then so are you.") + , ( "410a2b296df92b9a47412b13281df8f830a9f44b" + , "It's well we cannot hear the screams/That we create in others' dreams.") + , ( "841e7c85ca1adcddbdd0187f1289acb5c642f7f5" + , "You remind me of a TV show, but that's all right: I watch it anyway.") + , ( "163173b825d03b952601376b25212df66763e1db" + , "C is as portable as Stonehedge!!") + , ( "32b0377f2687eb88e22106f133c586ab314d5279" + , "Even if I could be Shakespeare, I think I should still choose to be Faraday. - A. Huxley") + , ( "0885aaf99b569542fd165fa44e322718f4a984e0" + , "The fugacity of a constituent in a mixture of gases at a given temperature is proportional to its mole fraction. Lewis-Randall Rule") + , ( "6627d6904d71420b0bf3886ab629623538689f45" + , "How can you write a big system without C++? -Paul Glick") + ] + +-- | Tests our SHA-1 implementation against coreutils'. +testCoreutilsConformance = + testProperty + "conformance with coreutils" + (testAgainstCoreutils sha1sum "sha1sum") + +-- | Tests our SHA-1 implementation against openssl(1)'s. +testOpensslConformance = + testProperty "conformance with OpenSSL" (testAgainstOpenssl sha1sum "sha1") + +-- Convenience function. + +sha1sum = show . sha1 . ByteString.Lazy.fromStrict diff --git a/tests/Data/Digest/Sha2Tests.hs b/tests/Data/Digest/Sha2Tests.hs index 248d23c..9efc714 100644 --- a/tests/Data/Digest/Sha2Tests.hs +++ b/tests/Data/Digest/Sha2Tests.hs @@ -4,19 +4,13 @@ module Data.Digest.Sha2Tests ( tests ) where -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as ByteString import qualified Data.ByteString.Lazy as ByteString.Lazy -import System.IO (hClose, hGetContents, hSetBinaryMode) -import System.Process - (CreateProcess(std_in, std_out), StdStream(CreatePipe), - createProcess_, proc) -import qualified Test.SmallCheck.Series.ByteString - as ByteString.Series import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit ((@?=), testCase) -import Test.Tasty.SmallCheck (monadic, over, testProperty) +import Test.Tasty.SmallCheck (testProperty) +import Data.Digest.HashTests + (goTestCase, testAgainstCoreutils, testAgainstOpenssl) import Data.Digest.Sha2 tests :: TestTree @@ -86,13 +80,6 @@ testNistSha512 = testGoExamples = testGroup "Go tests" [testGoSha224, testGoSha256, testGoSha384, testGoSha512] -goTestCase :: (ByteString -> String) -> (String, ByteString) -> TestTree -goTestCase f (output, input) = testCase description (f input @?= output) - where - description = - let (x, y) = ByteString.splitAt 11 input - in show (x `ByteString.append` if ByteString.null y then "" else "...") - testGoSha224 = testGroup "SHA-224" $ map @@ -498,23 +485,6 @@ testCoreutilsConformance = , testProperty "SHA-512" (testAgainstCoreutils sha512sum "sha512sum") ] -testAgainstCoreutils f prog = - over ByteString.Series.enumW8s $ \s -> - monadic $ do - theirs <- runExternal (proc prog ["-b"]) s - return (f s == head (words theirs)) - --- | Runs an external hashing command with the specified standard input. Assumes --- that the process will exit when its standard input is closed. -runExternal :: CreateProcess -> ByteString -> IO String -runExternal p s = do - (Just stdin, Just stdout, _, _) <- - createProcess_ "runExternal" (p {std_in = CreatePipe, std_out = CreatePipe}) - hSetBinaryMode stdin True - ByteString.hPut stdin s - hClose stdin -- causes process to exit - hGetContents stdout - -- | Tests our SHA-2 implementations against openssl(1)'s. testOpensslConformance = testGroup @@ -525,12 +495,6 @@ testOpensslConformance = , testProperty "SHA-512" (testAgainstOpenssl sha512sum "sha512") ] -testAgainstOpenssl f flag = - over ByteString.Series.enumW8s $ \s -> - monadic $ do - theirs <- runExternal (proc "openssl" ["dgst", '-' : flag]) s - return (f s == words theirs !! 1) - -- Convenience functions. sha224sum = show . sha224 . ByteString.Lazy.fromStrict diff --git a/tests/Tests.hs b/tests/Tests.hs index e14f836..34852db 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -4,7 +4,10 @@ module Main import Test.Tasty (defaultMain, testGroup) +import qualified Data.Digest.Sha1Tests import qualified Data.Digest.Sha2Tests main :: IO () -main = defaultMain $ testGroup "btls" [Data.Digest.Sha2Tests.tests] +main = + defaultMain $ + testGroup "btls" [Data.Digest.Sha1Tests.tests, Data.Digest.Sha2Tests.tests] -- cgit v1.2.3