Bound browser upload identity memory

test/Nuthatch/Test/UploadIdentityFixture.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+module Nuthatch.Test.UploadIdentityFixture
+  ( tests
+  ) where
+
+import           Crypto.Hash (Digest, SHA256, hash)
+import           Data.Aeson
+  ( FromJSON (..)
+  , eitherDecodeFileStrict
+  , withObject
+  , (.:)
+  )
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base16 as B16
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import           GHC.Generics (Generic)
+import           Test.Tasty (TestTree)
+import           Test.Tasty.HUnit (assertEqual, testCase)
+
+data Fixture = Fixture
+  { name    :: String
+  , source  :: FixtureSource
+  , sha256  :: T.Text
+  }
+  deriving stock (Generic)
+  deriving anyclass (FromJSON)
+
+data FixtureSource
+  = Utf8 T.Text
+  | Hex T.Text
+  | RepeatHex T.Text Int
+
+instance FromJSON FixtureSource where
+  parseJSON = withObject "FixtureSource" $ \object -> do
+    kind <- object .: "kind"
+    case (kind :: T.Text) of
+      "utf8" -> Utf8 <$> object .: "value"
+      "hex" -> Hex <$> object .: "value"
+      "repeat-hex" -> RepeatHex
+        <$> object .: "pattern"
+        <*> object .: "bytes"
+      _ -> fail ("unknown fixture source kind: " <> T.unpack kind)
+
+tests :: TestTree
+tests = testCase "Haskell SHA-256 matches browser upload identity fixtures" $ do
+  decoded <-
+    eitherDecodeFileStrict "web/test/fixtures/upload-content-sha256.json"
+      :: IO (Either String [Fixture])
+  fixtures <- either fail pure decoded
+  mapM_ verify fixtures
+
+verify :: Fixture -> IO ()
+verify Fixture {name, source, sha256} =
+  assertEqual name sha256 (digestHex (fixtureBytes source))
+
+digestHex :: BS.ByteString -> T.Text
+digestHex bytes =
+  TE.decodeUtf8 . B16.encode . BA.convert $
+    (hash bytes :: Digest SHA256)
+
+fixtureBytes :: FixtureSource -> BS.ByteString
+fixtureBytes = \case
+  Utf8 text -> TE.encodeUtf8 text
+  Hex text -> decodeHex text
+  RepeatHex patternText byteCount ->
+    let patternBytes = decodeHex patternText
+        repeats =
+          (byteCount + BS.length patternBytes - 1) `div` BS.length patternBytes
+    in BS.take byteCount (BS.concat (replicate repeats patternBytes))
+
+decodeHex :: T.Text -> BS.ByteString
+decodeHex text =
+  either error id (B16.decode (TE.encodeUtf8 text))