141 lines
4.5 KiB
Haskell
141 lines
4.5 KiB
Haskell
{-# 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)
|