Test and contract test the s3 interface

test/Main.hs

@@ -1,8 +1,14 @@
 module Main (main) where
 
 import qualified Test.Config
+import qualified Test.S3.Interface
 import Test.Hspec (hspec)
+import System.Environment (lookupEnv)
+import qualified Dhall
 
 main :: IO ()
-main = hspec $ do
-  Test.Config.spec
+main = do
+  config <- lookupEnv "TEST_CONFIG_PATH" >>= maybe (pure Nothing) (fmap Just . Dhall.inputFile Dhall.auto)
+  hspec $ do
+    Test.Config.spec
+    Test.S3.Interface.spec config

test/Test/S3/Interface.hs

@@ -0,0 +1,140 @@
+{-# LANGUAGE TypeApplications #-}
+module Test.S3.Interface where
+
+import Data.Generics.Labels ()
+import Control.Monad.Trans.Cont
+import Test.Hspec
+import Test.Hspec.Hedgehog
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+import S3.Interface
+import qualified Data.Conduit.Combinators as C
+import Conduit ((.|), runConduit, runResourceT, liftIO)
+import qualified Data.Text as T
+import System.FilePath (takeBaseName, (</>), (<.>))
+import qualified Data.ByteString.Char8 as BC
+import Data.Map (Map)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.Map.Strict as M
+import qualified Data.HashMap.Strict as HM
+import Data.Hashable (Hashable)
+import Data.Text (Text)
+import qualified Crypto.Random as Random
+import MyLib (hash)
+import System.IO.Temp (withSystemTempDirectory)
+import Crypto.Hash.Algorithms (SHA256)
+import Config.S3 (ConfigS3)
+import Crypto.Hash (Digest)
+
+withTempDir :: FilePath -> ContT r IO FilePath
+withTempDir path = ContT (withSystemTempDirectory path)
+
+-- XXX: Temporarily have the model just here
+buildModel :: FilePath -> IO S3Interface
+buildModel root =
+  pure S3Interface
+  { putFile = \path mt -> do
+      let key = T.pack . takeBaseName $ path
+      runResourceT $ do
+        runConduit $ C.sourceFileBS path .| C.sinkFileBS (root </> T.unpack key)
+        liftIO $ BC.writeFile (root </> T.unpack key <.> "metadata") (BC.pack $ show mt)
+      pure key
+  , getFile = \key outroot -> do
+      let outpath = outroot </> T.unpack key
+          inpath = root </> T.unpack key
+      runResourceT $ runConduit $ C.sourceFileBS inpath .| C.sinkFileBS outpath
+      pure outpath
+  , getMetadata = \key -> do
+      let path = root </> T.unpack key <.> "metadata"
+      read . BC.unpack <$> BC.readFile path
+  }
+
+genMetadata :: Gen Metadata
+genMetadata = convert <$> Gen.map (Range.linear 0 5) ((,) <$> text <*> text)
+  where
+    convert :: Hashable a => Map a b -> HashMap a b
+    convert = HM.fromList . M.toList
+    text = Gen.text (Range.linear 1 32) Gen.alpha
+
+data File = File { name :: Text, chunks :: Int, metadata :: Metadata }
+  deriving Show
+
+genFile :: Gen File
+genFile = File
+  <$> Gen.text (Range.linear 1 32) Gen.alphaNum
+  <*> Gen.integral (Range.linear 0 8192)
+  <*> genMetadata
+
+data FileCommand
+  = PutFile File
+  | ReadFile Int
+  | ReadMetadata Int
+  deriving Show
+
+genCommand :: Gen FileCommand
+genCommand = Gen.choice
+  [ PutFile <$> genFile
+  , ReadFile <$> Gen.integral (Range.linear 0 1000)
+  , ReadMetadata <$> Gen.integral (Range.linear 0 1000)
+  ]
+
+
+write :: FilePath -> File -> IO FilePath
+write root f = do
+  let path = root </> T.unpack (name f)
+  runResourceT $ runConduit $ C.replicateM (chunks f) (liftIO $ Random.getRandomBytes 256) .| C.sinkFileBS path
+  pure path
+
+specGetPut :: PropertyT IO ()
+specGetPut = do
+  file <- forAll genFile
+  (wanted, got) <- liftIO $ flip runContT pure $ do
+    root <- withTempDir "test-getput-in"
+    modelroot <- withTempDir "test-getput-model"
+    downloadroot <- withTempDir "test-getput-download"
+    liftIO $ do
+      interface <- buildModel modelroot
+      inpath <- write root file
+      key <- putFile interface inpath (metadata file)
+      outpath <- getFile interface key downloadroot
+      (,) <$> hash @SHA256 inpath <*> hash @SHA256 outpath
+  wanted === got
+
+data Result = Result
+  { resultKey :: Text
+  , resultHash :: Digest SHA256
+  , resultOriginHash :: Digest SHA256
+  }
+  deriving (Show, Eq)
+
+specGetPutS3 :: ConfigS3 -> PropertyT IO ()
+specGetPutS3 config = do
+  file <- forAll genFile
+  annotateShow file
+  (wanted, got) <- liftIO $ flip runContT pure $ do
+    root <- withTempDir "test-getput-in"
+    modelroot <- withTempDir "test-getput-model"
+    downloadroot <- withTempDir "test-getput-download"
+    liftIO $ do
+      inpath <- write root file
+      let mt = metadata file
+      modelInt <- buildModel modelroot
+      s3Int <- buildInterface config
+      (,) <$> create modelInt downloadroot inpath mt <*> create s3Int downloadroot inpath mt
+  wanted === got
+  where
+    create interface downloadroot inpath mt = do
+      key <- putFile interface inpath mt
+      s3path <- getFile interface key downloadroot
+      Result <$> pure key <*> hash s3path <*> hash inpath
+
+-- Contract test for the interface
+
+spec :: Maybe ConfigS3 -> Spec
+spec mConfig =
+  describe "Contract test between S3 and the model" $ do
+    context "Model" $ do
+      it "satisfies the get-put property for content" $ hedgehog specGetPut
+    flip (maybe (pure ())) mConfig $ \config -> do
+      context "S3" $ do
+        it "satisfies the get-put property for content" $ hedgehog (specGetPutS3 config)