Main.hs

-- ------------------------------------------------------ --
-- Copyright © 2014 AlephCloud Systems, Inc.
-- ------------------------------------------------------ --

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}

-- |
-- Module: Main
-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.
-- License: BSD3
-- Maintainer: Lars Kuhtz <lars@alephcloud.com>
-- Stability: experimental
--
-- Tests for Haskell AWS DynamoDb bindings
--

module Main
( main
) where

import Aws
import qualified Aws.DynamoDb as DY

import Control.Arrow (second)
import Control.Error
import Control.Monad
import Control.Monad.IO.Class

import Data.IORef
import qualified Data.List as L
import qualified Data.Text as T

import qualified Network.HTTP.Client as HTTP

import Test.Tasty
import Test.QuickCheck.Instances ()

import System.Environment
import System.Exit

import Utils
import DynamoDb.Utils

-- -------------------------------------------------------------------------- --
-- Main

main :: IO ()
main = do
    args <- getArgs
    runMain args $ map (second tail . span (/= '=')) args
  where
    runMain :: [String] -> [(String,String)] -> IO ()
    runMain args _argsMap
        | any (`elem` helpArgs) args = defaultMain tests
        | "--run-with-aws-credentials" `elem` args =
            withArgs (tastyArgs args) . defaultMain $ tests
        | otherwise = putStrLn help >> exitFailure

    helpArgs = ["--help", "-h"]
    mainArgs =
        [ "--run-with-aws-credentials"
        ]
    tastyArgs args = flip filter args $ \x -> not
        $ any (`L.isPrefixOf` x) mainArgs


help :: String
help = L.intercalate "\n"
    [ ""
    , "NOTE"
    , ""
    , "This test suite accesses the AWS account that is associated with"
    , "the default credentials from the credential file ~/.aws-keys."
    , ""
    , "By running the tests in this test-suite costs for usage of AWS"
    , "services may incur."
    , ""
    , "In order to actually execute the tests in this test-suite you must"
    , "provide the command line options:"
    , ""
    , "    --run-with-aws-credentials"
    , ""
    , "When running this test-suite through cabal you may use the following"
    , "command:"
    , ""
    , "    cabal test --test-option=--run-with-aws-credentials dynamodb-tests"
    , ""
    ]

tests :: TestTree
tests = testGroup "DynamoDb Tests"
    [ test_table
    -- , test_message
    , test_core
    ]

-- -------------------------------------------------------------------------- --
-- Table Tests

test_table :: TestTree
test_table = testGroup "Table Tests"
    [ eitherTOnceTest1 "CreateDescribeDeleteTable" (prop_createDescribeDeleteTable 10 10)
    ]

-- |
--
prop_createDescribeDeleteTable
    :: Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB)
    -> Int -- ^ write capacity (#writes * itemsize/1KB)
    -> T.Text -- ^ table name
    -> ExceptT T.Text IO ()
prop_createDescribeDeleteTable readCapacity writeCapacity tableName = do
    tTableName <- testData tableName
    tryT $ createTestTable tTableName readCapacity writeCapacity
    let deleteTable = retryT 6 . void $ simpleDyT (DY.DeleteTable tTableName)
    flip catchE (\e -> deleteTable >> throwE e) $ do
        retryT 6 . void . simpleDyT $ DY.DescribeTable tTableName
        deleteTable

-- -------------------------------------------------------------------------- --
-- Test core functionality

test_core :: TestTree
test_core = testGroup "Core Tests"
        [ eitherTOnceTest0 "connectionReuse" prop_connectionReuse
        ]

prop_connectionReuse
    :: ExceptT T.Text IO ()
prop_connectionReuse = do
    c <- liftIO $ do
        cfg <- baseConfiguration

        -- counts the number of TCP connections
        ref <- newIORef (0 :: Int)

        manager <- HTTP.newManager (managerSettings ref)
        void $ runExceptT $
            flip catchE (error . T.unpack) . replicateM_ 3 $ do
                void $ dyT cfg manager DY.ListTables
                mustFail . dyT cfg manager $ DY.DescribeTable "____"

        readIORef ref
    unless (c == 1) $
        throwE "The TCP connection has not been reused"
  where
    managerSettings ref = HTTP.defaultManagerSettings
        { HTTP.managerRawConnection = do
            mkConn <- HTTP.managerRawConnection HTTP.defaultManagerSettings
            return $ \a b c -> do
                atomicModifyIORef ref $ \i -> (succ i, ())
                mkConn a b c
        }