configuration-tools-0.2.9: test/TestTools.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}

-- |
-- Module: TestTools
-- Description: Tools for testing program configurations
-- Copyright: Copyright © 2015 PivotCloud, Inc.
-- License: MIT
-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>
-- Stability: experimental
--
-- Tools for testing program configurations
--
module TestTools
(
-- * Very Simple Debugging
  enableDebug
, debug

-- * Configuration Assertions for Testing
, ConfAssertion(..)
, trueLens
, trueAssertion

-- * Test Execution
, check
, runTest

-- * Test Configuration Files
, withConfigFile
, withConfigFileText
#ifdef REMOTE_CONFIGS
, ConfigType(..)
, serverUrl
, serverTlsUrl
, withConfigFileServer
#endif
) where

import Configuration.Utils
import Configuration.Utils.Internal

import Control.Exception
import Control.Monad

import qualified Data.ByteString.Char8 as B8
import Data.IORef
import Data.Monoid.Unicode
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Yaml as Yaml

import Distribution.Simple.Utils (withTempFile)

import Prelude.Unicode

import System.Environment
import System.IO

#ifdef REMOTE_CONFIGS
import Control.Concurrent
import qualified Data.ByteString.Lazy as LB
import Data.Maybe
import qualified Data.Text.Encoding as T
import qualified Network.Wai as WAI
import qualified Network.Wai.Handler.Warp as WARP
import qualified Network.Wai.Handler.WarpTLS as WARP
import qualified Network.HTTP.Types as HTTP
#endif

-- -------------------------------------------------------------------------- --
-- Very Simple Debugging

enableDebug ∷ Bool
enableDebug = False

debug
    ∷ Monad m
    ⇒ m ()
    → m ()
debug a
    | enableDebug = a
    | otherwise = return ()

-- -------------------------------------------------------------------------- --
-- Configuration Assertions for Testing

-- | Specify a assertion about the parsed configuration
--
-- The parameters are
--
-- 1. list of command line arguments,
-- 2. lens for the configuration value
-- 3. the expected value
--
data ConfAssertion β = ∀ α . Eq α ⇒ ConfAssertion [String] (Lens' β α) α

trueLens ∷ Lens' β ()
trueLens = lens (const ()) const

trueAssertion ∷ [String] → ConfAssertion β
trueAssertion args = ConfAssertion args trueLens ()

-- -------------------------------------------------------------------------- --
-- Test execution

-- Check the given list of assertions for the given configuration value
--
check
    ∷ α
    → [ConfAssertion α]
    → IO Bool
check conf assertions =
    foldM (\a (b,n) → (&& a) <$> go b n) True $ zip assertions [0 ∷ Int ..]
  where
    go (ConfAssertion _ l v) n =
        if view l conf ≡ v
          then do
            debug ∘ T.putStrLn $ "DEBUG: assertion " ⊕ sshow n ⊕ " succeeded"
            return True
          else do
            debug ∘ T.putStrLn $ "DEBUG: assertion " ⊕ sshow n ⊕ " failed"
            return False

-- | Run a test with an expected outcome ('True' or 'False')
-- for a given that of assertions.
--
runTest
    ∷ (FromJSON (α → α), ToJSON α)
    ⇒ PkgInfo
    → ProgramInfoValidate α []
    → T.Text
        -- ^ label for the test case
    → Bool
        -- ^ expected outcome
    → [ConfAssertion α]
        -- ^ test assertions
    → IO Bool
runTest pkgInfo mInfo label succeed assertions = do

    debug ∘ T.putStrLn $ "\nDEBUG: ======> " ⊕ label

    debug ∘ T.putStrLn $ "DEBUG: runWithPkgInfoConfiguration"
    a ← run $ runWithPkgInfoConfiguration mInfo pkgInfo

    debug ∘ T.putStrLn $ "DEBUG: runWithConfiguration"
    b ← run $ runWithConfiguration mInfo

    if a ≡ b && succeed ≡ (a && b)
      then
        return True
      else do
        T.putStrLn $ "WARNING: test " ⊕ label ⊕ " failed"
        return False
  where
    run f = do
        ref ← newIORef False
        handle (handler ref) $ withArgs args ∘ f $ \conf →
            writeIORef ref =<< check conf assertions
        readIORef ref

    args = concatMap (\(ConfAssertion x _ _) → x) assertions

    handler ref (e ∷ SomeException) = do
        writeIORef ref False
        debug ∘ T.putStrLn $ "DEBUG: caught exception: " ⊕ sshow e

-- -------------------------------------------------------------------------- --
-- Test Config Files
--

withConfigFile
    ∷ ToJSON γ
    ⇒ γ
    → (T.Text → IO α)
    → IO α
withConfigFile config inner =
    withTempFile "." "tmp_TestExample.yml" $ \tmpPath tmpHandle → do
        B8.hPutStrLn tmpHandle ∘ Yaml.encode $ config
        hClose tmpHandle
        inner $ T.pack tmpPath

withConfigFileText
    ∷ T.Text
    → (T.Text → IO α)
    → IO α
withConfigFileText configText inner =
    withTempFile "." "tmp_TestExample.yml" $ \tmpPath tmpHandle → do
        T.hPutStrLn tmpHandle configText
        hClose tmpHandle
        inner $ T.pack tmpPath


#ifdef REMOTE_CONFIGS
data ConfigType = ∀ γ . ToJSON γ ⇒ ConfigType γ

instance ToJSON ConfigType where
    toJSON (ConfigType a) = toJSON a

withConfigFileServer
    ∷ [(T.Text, ConfigType)]
    → [(T.Text, T.Text)]
    → IO α
    → IO α
withConfigFileServer configs configTexts inner = do
    void ∘ forkIO $ WARP.run serverPort app
    void ∘ forkIO $ WARP.runTLS tlsSettings (warpSettings serverTlsPort) app
    inner
  where
    app req respond = do
        let maybeBody = LB.fromStrict <$> do
                p ← listToMaybe $ WAI.pathInfo req
                do
                    Yaml.encode <$> lookup p configs
                    <|>
                    (T.encodeUtf8 <$> lookup p configTexts)

        respond $ case maybeBody of
            Just body → WAI.responseLBS HTTP.status200 [] body
            Nothing → WAI.responseLBS HTTP.status404 [] "resource not found"

serverPort ∷ Int
serverPort = 8283

serverTlsPort ∷ Int
serverTlsPort = 8284

serverUrl ∷ T.Text
serverUrl = "http://127.0.0.1:" ⊕ sshow serverPort

serverTlsUrl ∷ T.Text
serverTlsUrl = "https://127.0.0.1:" ⊕ sshow serverTlsPort

tlsSettings ∷ WARP.TLSSettings
tlsSettings = WARP.tlsSettingsMemory serverCert serverKey

warpSettings ∷ Int → WARP.Settings
warpSettings port = WARP.setPort port WARP.defaultSettings

serverCert ∷ B8.ByteString
serverCert = B8.unlines
    [ "-----BEGIN CERTIFICATE-----"
    , "MIIF5TCCA82gAwIBAgIJAPT8MspOLMHrMA0GCSqGSIb3DQEBCwUAMFQxCzAJBgNV"
    , "BAYTAlVTMRMwEQYDVQQIEwpTb21lLVN0YXRlMRwwGgYDVQQKExNjb25maWd1cmF0"
    , "aW9uLXRvb2xzMRIwEAYDVQQDEwlsb2NhbGhvc3QwIBcNMTUwMjAzMjMzNjIyWhgP"
    , "MjExNTAxMTAyMzM2MjJaMFQxCzAJBgNVBAYTAlVTMRMwEQYDVQQIEwpTb21lLVN0"
    , "YXRlMRwwGgYDVQQKExNjb25maWd1cmF0aW9uLXRvb2xzMRIwEAYDVQQDEwlsb2Nh"
    , "bGhvc3QwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQCtXCeoaw1m+JaX"
    , "qJnxKdOelNJxuZxPFoNN2tNIxY+63H6yH9XkhDw1bTPsTv2YX0ZdNxGHprh2a5jP"
    , "Z5gUh2EUsPnSNhnVhAGef3Y2gfAxeT1k81Ap4IKhBq9Drmlg7uJOPkqBkUhMi675"
    , "pVtxb2oSOrH4wkJD9n47dGSl2ziuUejfhzc0oZcVEs/w90KFkfNvTYXzSJfjU+WJ"
    , "KX2h0VI3m33lBbreyGktoccImF6+gHNKC0m+L74MyfLzu3TDlg7a+YwEOhCu2Tbf"
    , "kdPcSvSW0xEo9yn4epcGL+bRLXsT8DYQSE0q7sJf0I6y+nespoPCpfWnWinKbs7n"
    , "xNDl7wfD4spYcV19lgAicv7l1W+ItB3A/8KOSD+a7bc5LY7svKwBPV5ZQ4jRkvoa"
    , "Efcztv7i89/CjurCm3TX2oespTqCUOKYlc61NQQ9l//2yoBPY2IvBKUOPpDHSyn+"
    , "ZuMKdNu0mzdTHDjsbNW/es2n8Uk1wG+bQ60ZWCkixJZ/SCECBJpt1qkkgh9iclh+"
    , "abTBXBSU+N8DmyO9UACV9LlsBkKxjfK4F+mlodgP5C9R6nPlpYB7W9cuLvIWQnuR"
    , "DSnW6fS1T0g77mXMFeB8bjnADq7dM3aQXisvkX/XGT1KfsJdTqoau3dFMYArFpx9"
    , "0LqEh6pmt2rkNfFNPHnSx/hzVKr0ZwIDAQABo4G3MIG0MB0GA1UdDgQWBBRPlQCM"
    , "ToNUODspmRtqhXHcidXpRDCBhAYDVR0jBH0we4AUT5UAjE6DVDg7KZkbaoVx3InV"
    , "6UShWKRWMFQxCzAJBgNVBAYTAlVTMRMwEQYDVQQIEwpTb21lLVN0YXRlMRwwGgYD"
    , "VQQKExNjb25maWd1cmF0aW9uLXRvb2xzMRIwEAYDVQQDEwlsb2NhbGhvc3SCCQD0"
    , "/DLKTizB6zAMBgNVHRMEBTADAQH/MA0GCSqGSIb3DQEBCwUAA4ICAQAJfpa2Ju9j"
    , "Om7M5U9cQUZaYKqKe2N6+fx4y7C6J9oHAVjXzhevPm307I7MyVWpzh8+AShEnzyY"
    , "R83M8hL61cMOCjU3YOl6exz1jUYHXKhj0chl18z6wDM9o8NkoG4iFDbEipAtciKm"
    , "UbU+vm2d9z6mC+VN6xPVa9S72/+dRvyIgkPl3hQOZ5wKYic/7/EXM0MldQ7gb6KO"
    , "UuYDlr5aEHvF1J8Fnju5RzVofCPbC2obiwJN3RnYYFJv5pybQdnYfBg4z8OzgiQf"
    , "V/OVndzqyHWLg21MxPExM/PHFyuzeAh6e3lu6F1XhwoA4H8UzN1Gei2B8HfNQ54O"
    , "xyzeBu+kdPPzC0xQFm/s80CG+OPhtTd2ka6N2/YwgMSL6QOTQ1J7zpIwfsIgCaNH"
    , "Fkjj0gJk82+URMwjMhyh6m49qwhanL/9yodmascr27o10ZmAq6570C+zqaUoVk8y"
    , "m/PMNTHMLsSddjkelAKSjVU9+PQDRgnZTPiNhpEswgAbF8UjNkyxBRjBUrBIEGWd"
    , "k+PNgjOH3HPT3nWXYyTNTjAJQ7D5RVwFiROMdHdZdFjaxjRQpRkMvR/rpEdsf89H"
    , "75OZcCJzjg03soMUQ+ySp8Ax2Z6PSC1Cbvu+P+aOB0lyNpMYFuL0LVq5iWb6GmcB"
    , "5wxh9JKKsOVBhPDpOQlEAyRqtdXGbOwHNg=="
    , "-----END CERTIFICATE-----"
    ]

serverKey ∷ B8.ByteString
serverKey = B8.unlines
    [ "-----BEGIN RSA PRIVATE KEY-----"
    , "MIIJKAIBAAKCAgEArVwnqGsNZviWl6iZ8SnTnpTScbmcTxaDTdrTSMWPutx+sh/V"
    , "5IQ8NW0z7E79mF9GXTcRh6a4dmuYz2eYFIdhFLD50jYZ1YQBnn92NoHwMXk9ZPNQ"
    , "KeCCoQavQ65pYO7iTj5KgZFITIuu+aVbcW9qEjqx+MJCQ/Z+O3Rkpds4rlHo34c3"
    , "NKGXFRLP8PdChZHzb02F80iX41PliSl9odFSN5t95QW63shpLaHHCJhevoBzSgtJ"
    , "vi++DMny87t0w5YO2vmMBDoQrtk235HT3Er0ltMRKPcp+HqXBi/m0S17E/A2EEhN"
    , "Ku7CX9COsvp3rKaDwqX1p1opym7O58TQ5e8Hw+LKWHFdfZYAInL+5dVviLQdwP/C"
    , "jkg/mu23OS2O7LysAT1eWUOI0ZL6GhH3M7b+4vPfwo7qwpt019qHrKU6glDimJXO"
    , "tTUEPZf/9sqAT2NiLwSlDj6Qx0sp/mbjCnTbtJs3Uxw47GzVv3rNp/FJNcBvm0Ot"
    , "GVgpIsSWf0ghAgSabdapJIIfYnJYfmm0wVwUlPjfA5sjvVAAlfS5bAZCsY3yuBfp"
    , "paHYD+QvUepz5aWAe1vXLi7yFkJ7kQ0p1un0tU9IO+5lzBXgfG45wA6u3TN2kF4r"
    , "L5F/1xk9Sn7CXU6qGrt3RTGAKxacfdC6hIeqZrdq5DXxTTx50sf4c1Sq9GcCAwEA"
    , "AQKCAgBnaupdlj9QhkuP/YyYSZNsrus73LZal9uMvlX8u56aop8SM9utjxU76gFn"
    , "n1e5ZlzbjtZuTg8M1fM7B1m6JWjMpybhOFUBAtbUbsVejvVzDhiJ+HyB/uTumsZD"
    , "YfCLWva2JoLb+Idg4pNnajW63fQxG8K/22McmBeF8FF6f+S4WTTK5CcSxrMSZz6V"
    , "SWvtsru+UkjucQfrHUl5Ib9IoU6izae00E5CSNw11KSfhAZBLu+X5FQBmQmPJ4o/"
    , "zDxD0WjbSLM2ck0xgXMyvBPe/vgaYZ+DCK+JA9jEYB8Z+j/KDSqzW+5tBjH+ZrQ6"
    , "ISDzZgKEQ+zgAPGdSa00pjzYblf6jy2WUDwB38EtecuIxswmfuwWbSX0VGU2Pujl"
    , "2V/JonJv/j23MsRjYxcrgfZowdbSjFJtxkHRZiHvguKMZ+2hp23PonwLRe33zqSV"
    , "PE3YLy/R5wjN7EMUCccVqKb4VdOrIBl6sfZGzoGymE4Fq6x0+ueWuwammiNeegi2"
    , "UXAj93c8kBnfIh6397bfMgM6nLY/NK/igtO4cjuOP2aZpUD0oDzHDTkf+E9Ezavs"
    , "HDqMMuIgxHlKRmWAaw5LIWHsVYpekt9x9zuvb3lCMYOu2gr6XlxLR0L9SPR38uMG"
    , "WJNgo11qt5LCeFdXLBqP5WhqCb7yW2/BLiZM3ihSV/Yn5aZegQKCAQEA5bwEbZke"
    , "UxSljlz7UChbHAeHXrMN7t0+RueRE1hn5pMdZLTaLiUA+qnaCAgWWeeNqUnTRGpN"
    , "DD1/+0D3+5XDNtQiw93vIM/eXBN2HVzqKcPBggPmoIY99/e3vi+VYT8PQt0Sd+Tw"
    , "tfkGNpMen2F+YNWBg9NGtwAs1xDDrzLVD1c4gAxfAv2noywBbkRbn/UQbhcd6ebl"
    , "2DDKJVbZiCSnGAx2nZupet/R1W6fGWqYNv5+Gd/XRhrtwOdLEU6WqE3xN0VWK06y"
    , "D3fR6wPkScZM2UXupgsZyJMPVdb68mah+skOx0wZMWxYzmzDWaDm1kwlmP8FZBtr"
    , "jY3BtKdKza5X6QKCAQEAwS4kQUAkMzyzdScp8TV9dZnvf3QsajB5pTFfsWiGmkzx"
    , "kQQVvIX7L70Phh+oIHxaWhxxWw7J2G1QZu/bnrv+nDviGHo+ZEqY+7mPY/AVC3f4"
    , "i2mLAj61c+p2HtlFo0ZPntTClXHWR+jsA2z+zk2L2LxmvJFdfngOaHkAT5pg34CT"
    , "bJJMucNs0efEiGNgPCTIaZNPH5HW2lHPTOreRFImh843WsS0iLkWG9gMz6F5jkNr"
    , "ReGpJ3432dq91xot0iJ4Qo9cAEo8rra1BgbeJC7IIeLUt8Ud7lDGdTkzPMajqItO"
    , "jat/veec0+9tWzrUu/F6hBWrLtH8Q94ug2pNseaHzwKCAQB79HurKv/qsew2KUNM"
    , "V8n5ELLgzNnKtUNh/JYRixTcmyoz6UUDuuGRXk4PIVX2AnM0EWpVssmJvjEsvzxO"
    , "Wdsv3Tw41Kmu2ZnPsox7gWOzTzU80qAAow4Smm1gx8ng46Z3XFMXr8aVWR0aGz1d"
    , "n7wRwYGVQE0adpS7IgeDo3jEQzpwFLy7H2PxLdBDz8xkPVU1IXH5f6UqhgC8LuVG"
    , "iQhDeI4Tsia67sMIVxyvGQ2yNpSRn25HHEaGXAXr+6xceVmaieXZjieTIwJ3vOzT"
    , "RZS3cv02SC0MRRT0Kv/SBMCHUS6RKCU7vosYLiUlWiTTIdjzeT5OamEYypDmyZEZ"
    , "82TpAoIBABX5iLg/cp69dfCKrvO4UPgytZK7BV5i+0N2VVtZ943P2N7VJx/V4dfx"
    , "WrW4Hijr3F9Jwv9HtGBBNxcui74HxpPBIBwGs9g2wCZKWmxU4B/42rYJIH314jA4"
    , "aI1jy88h7Wa07xmO5IAzl71gBbA0FAdojws+QfNj9sedlBJ6DjD+cEa2cbHj8BoE"
    , "kk+tdkIBMScJUcPWlCkrizhFs1j0O1vRcmyJ2bt/ymsKbZKk3K35L1e4rsRGUFYg"
    , "0t2IJdQ0hZeUtTN3PmXldLwlxdk51Rw9sFLjQl9couasxg5Qzkca6aml65cPpMBb"
    , "CQaKr65dbsFdsaZWzqptuL7MNeBZx/MCggEBALqzujabof6VsX1+BrBeV6iz7VNV"
    , "ECHRaxDH7BIfLXWcP++nZH8nboBjnm7vE8ZBx7m8v1I2uWPQ/pkeClcRmtVeo+PW"
    , "Q9ITFaAmfMiJx/2VzOt9Ze5DT35kTyx4nt5dZ7znnSTqEvP2AEB8GY8zP6yy61Pd"
    , "Yw0cd2Buw0NqmWOIK83WSv44g7+maAkv4Jph5YA0lM3tQPwuKNFWNK2oOT5P911j"
    , "2GQMvNO99jq+FAf7XEL4WAZj+KOk0RBPa82dg8xTUMXEFhYHPhVfOpEZU3H099pM"
    , "Oo6zONyBMHTJazFr6atuwRR6RFRzHmMaJ0K72FBuHb4F31X+yOTSKT8rea0="
    , "-----END RSA PRIVATE KEY-----"
    ]
#endif