S3.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Test.Mismi.S3 (
    module X

  , Token (..)
  , genToken

  , LocalPath (..)
  , genLocalPath

  , testBucket
  , createSmallFiles
  , files
  , newAddress
  , newFilePath
  , addCleanupFinalizer
  , addPrintFinalizer
  , addLocalCleanupFinalizer
  , addLocalPrintFinalizer
  ) where


import           Control.Monad.Catch
import           Control.Monad.Reader (ask)
import           Control.Monad.Trans.Class (lift)
import           Control.Monad.Trans.Except
import           Control.Monad.Trans.Resource
import           Control.Monad.IO.Class (MonadIO, liftIO)

import qualified Data.List as L
import           Data.Text as T
import qualified Data.Text.IO as T
import           Data.UUID as U
import           Data.UUID.V4 as U

import           Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

import           System.Environment (lookupEnv)
import           System.Posix.Env
import           System.FilePath
import           System.Directory

import           Mismi.Control
import           Mismi.S3

import           P

import           Test.Mismi as X

data Token =
  Token {
      unToken :: Text
    } deriving (Eq, Show)

genToken :: Gen Token
genToken = do
  let
    genA = Gen.text (Range.linear 10 15) Gen.alphaNum
    genB = Gen.text (Range.linear 5 10) Gen.alphaNum

  n <- T.pack . show <$> (Gen.int $ Range.linear 0 10000)
  c <- genA
  m <- genB
  sep <- Gen.element ["-", "=", "."]
  pure . Token . T.intercalate sep $ [c, m, n]

data LocalPath =
  LocalPath {
      localPath :: FilePath
    } deriving (Eq, Show)

genLocalPath :: Gen LocalPath
genLocalPath =  do
  let
    gen = Gen.text (Range.linear 5 10) Gen.alphaNum

  x <- gen
  xs <- Gen.list (Range.linear 0 5) gen
  pure . LocalPath $ L.intercalate "/" (T.unpack <$> x : xs)

testBucket :: IO Bucket
testBucket =
  Bucket . T.pack . fromMaybe "ambiata-dev-view" <$> getEnv "AWS_TEST_BUCKET"

createSmallFiles :: Address -> Text -> Int -> PropertyT AWS ()
createSmallFiles prefix name n = do
  lift . mapM_ (flip write "data") $ files prefix name n

files :: Address -> Text -> Int -> [Address]
files prefix name n =
  fmap (\i -> withKey (// Key (name <> "-" <> (T.pack $ show i))) prefix) [1..n]

newAddress :: PropertyT AWS Address
newAddress = do
  a <- liftIO $ do
    t <- Gen.sample genToken
    b <- testBucket
    u <- T.pack . U.toString <$> U.nextRandom
    pure $ Address b (Key . T.intercalate "/" $ ["mismi", u, unToken t])
  lift $ addCleanupFinalizer a
  lift $ addPrintFinalizer a
  pure $ a

newFilePath :: PropertyT AWS FilePath
newFilePath = do
  p <- liftIO $ do
    t <- Gen.sample genToken
    d <- getTemporaryDirectory
    u <- liftIO $ U.toString <$> U.nextRandom
    let p = d <> "/mismi/" <> u <> "-" <> (T.unpack . unToken $ t)
    createDirectoryIfMissing True p
    pure p
  lift$ addLocalCleanupFinalizer p
  lift $ addLocalPrintFinalizer p
  pure p

vk :: MonadIO m => Text -> m Bool
vk k = do
  m <- liftIO $ lookupEnv (T.unpack k)
  return $ maybe False (\v -> v == "1" || v == "true") m

addCleanupFinalizer :: Address -> AWS ()
addCleanupFinalizer a = do
  e <- ask
  r <- vk "TEST_SKIP_CLEANUP_RESOURCES"
  p <- vk "TEST_PRINT_CLEANUP_RESOURCES"
  unless r .
    void $ register (either throwM pure =<< runExceptT (runAWS e $
      listRecursively a >>= mapM_ delete >> delete a))
  when p .
    void $ register (T.putStrLn $ "Cleaning up [" <> addressToText a <> "]")

addPrintFinalizer :: Address -> AWS ()
addPrintFinalizer a = do
  r <- vk "TEST_PRINT_PATHS"
  when r .
    void $ register (T.putStrLn $ "Temporary s3 address [" <> addressToText a <> "]")

addLocalCleanupFinalizer :: FilePath -> AWS ()
addLocalCleanupFinalizer a = do
  r <- vk "TEST_SKIP_CLEANUP_RESOURCES"
  p <- vk "TEST_PRINT_CLEANUP_RESOURCES"
  unless r .
    void $ register (removeDirectoryRecursive a)
  when p .
    void $ register (T.putStrLn $ "Cleaning up [" <> T.pack a <> "]")

addLocalPrintFinalizer :: FilePath -> AWS ()
addLocalPrintFinalizer a = do
  r <- vk "TEST_PRINT_PATHS"
  when r .
    void $ register (T.putStrLn $ "Temporary local filepath [" <> T.pack a <> "]")