{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
--
-- Copyright (c) 2005-2022   Stefan Wehr - http://www.stefanwehr.de
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
--
{- |
Internal module for retaining a history of test runs.
-}
module Test.Framework.History (

    TestHistory, HistoricTestResult(..), emptyTestHistory, Milliseconds, TestResult(..)
  , serializeTestHistory, deserializeTestHistory
  , findHistoricTestResult, findHistoricSuccessfulTestResult
  , updateTestHistory, mkTestRunHistory
  , historyTests

) where

import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as T
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.List as L
import qualified Data.Vector as V
import Data.Time.Clock
import Test.HUnit
import Data.Aeson hiding (Error)
import Data.Aeson.TH
import Test.Framework.TestInterface

-- | A type synonym for time in milliseconds.
type Milliseconds = Int

data TestHistory
    = TestHistory
      { TestHistory -> Vector TestRunHistory
th_runs :: !(V.Vector (TestRunHistory)) -- reverse chronologically sorted
      , TestHistory -> Map Text HistoricTestResult
th_index :: !(Map T.Text (HistoricTestResult))
      , TestHistory -> Map Text HistoricTestResult
th_successfulIndex :: !(Map T.Text (HistoricTestResult))
      }
    deriving (TestHistory -> TestHistory -> Bool
(TestHistory -> TestHistory -> Bool)
-> (TestHistory -> TestHistory -> Bool) -> Eq TestHistory
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestHistory -> TestHistory -> Bool
== :: TestHistory -> TestHistory -> Bool
$c/= :: TestHistory -> TestHistory -> Bool
/= :: TestHistory -> TestHistory -> Bool
Eq)

instance Show (TestHistory) where
    showsPrec :: Int -> TestHistory -> ShowS
showsPrec Int
_ TestHistory
_ = [Char] -> ShowS
showString [Char]
"<TestHistory>"

emptyTestHistory :: TestHistory
emptyTestHistory :: TestHistory
emptyTestHistory =
    Vector TestRunHistory
-> Map Text HistoricTestResult
-> Map Text HistoricTestResult
-> TestHistory
TestHistory Vector TestRunHistory
forall a. Vector a
V.empty Map Text HistoricTestResult
forall k a. Map k a
Map.empty Map Text HistoricTestResult
forall k a. Map k a
Map.empty

data TestRunHistory
    = TestRunHistory
      { TestRunHistory -> UTCTime
trh_startTime :: !UTCTime
      , TestRunHistory -> Vector HistoricTestResult
trh_tests :: !(V.Vector (HistoricTestResult))
      }
    deriving (TestRunHistory -> TestRunHistory -> Bool
(TestRunHistory -> TestRunHistory -> Bool)
-> (TestRunHistory -> TestRunHistory -> Bool) -> Eq TestRunHistory
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestRunHistory -> TestRunHistory -> Bool
== :: TestRunHistory -> TestRunHistory -> Bool
$c/= :: TestRunHistory -> TestRunHistory -> Bool
/= :: TestRunHistory -> TestRunHistory -> Bool
Eq)

instance Show TestRunHistory where
    showsPrec :: Int -> TestRunHistory -> ShowS
showsPrec Int
d TestRunHistory
trh =
        Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
        [Char] -> ShowS
showString [Char]
"TestRunHistory <hidden time> " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        Int -> Vector HistoricTestResult -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 (TestRunHistory -> Vector HistoricTestResult
trh_tests TestRunHistory
trh)

data HistoricTestResult
    = HistoricTestResult
      { HistoricTestResult -> Text
htr_testId :: !T.Text
      , HistoricTestResult -> TestResult
htr_result :: !TestResult
      , HistoricTestResult -> Bool
htr_timedOut :: !Bool
      , HistoricTestResult -> Int
htr_timeMs :: !Milliseconds
      }
    deriving (Int -> HistoricTestResult -> ShowS
[HistoricTestResult] -> ShowS
HistoricTestResult -> [Char]
(Int -> HistoricTestResult -> ShowS)
-> (HistoricTestResult -> [Char])
-> ([HistoricTestResult] -> ShowS)
-> Show HistoricTestResult
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HistoricTestResult -> ShowS
showsPrec :: Int -> HistoricTestResult -> ShowS
$cshow :: HistoricTestResult -> [Char]
show :: HistoricTestResult -> [Char]
$cshowList :: [HistoricTestResult] -> ShowS
showList :: [HistoricTestResult] -> ShowS
Show, HistoricTestResult -> HistoricTestResult -> Bool
(HistoricTestResult -> HistoricTestResult -> Bool)
-> (HistoricTestResult -> HistoricTestResult -> Bool)
-> Eq HistoricTestResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HistoricTestResult -> HistoricTestResult -> Bool
== :: HistoricTestResult -> HistoricTestResult -> Bool
$c/= :: HistoricTestResult -> HistoricTestResult -> Bool
/= :: HistoricTestResult -> HistoricTestResult -> Bool
Eq)

mkTestRunHistory :: UTCTime -> [HistoricTestResult] -> TestRunHistory
mkTestRunHistory :: UTCTime -> [HistoricTestResult] -> TestRunHistory
mkTestRunHistory UTCTime
time [HistoricTestResult]
results = TestRunHistory {
                                  trh_startTime :: UTCTime
trh_startTime = UTCTime
time
                                , trh_tests :: Vector HistoricTestResult
trh_tests = [HistoricTestResult] -> Vector HistoricTestResult
forall a. [a] -> Vector a
V.fromList [HistoricTestResult]
results
                                }

isSuccess :: HistoricTestResult -> Bool
isSuccess :: HistoricTestResult -> Bool
isSuccess HistoricTestResult
r = HistoricTestResult -> TestResult
htr_result HistoricTestResult
r TestResult -> TestResult -> Bool
forall a. Eq a => a -> a -> Bool
== TestResult
Pass Bool -> Bool -> Bool
&& Bool -> Bool
not (HistoricTestResult -> Bool
htr_timedOut HistoricTestResult
r)

updateTestHistory :: TestRunHistory -> TestHistory -> TestHistory
updateTestHistory :: TestRunHistory -> TestHistory -> TestHistory
updateTestHistory TestRunHistory
runHistory TestHistory
history =
    let runs :: [TestRunHistory]
runs = TestRunHistory
runHistory TestRunHistory -> [TestRunHistory] -> [TestRunHistory]
forall a. a -> [a] -> [a]
: Vector TestRunHistory -> [TestRunHistory]
forall a. Vector a -> [a]
V.toList (TestHistory -> Vector TestRunHistory
th_runs TestHistory
history)
    in Vector TestRunHistory
-> Map Text HistoricTestResult
-> Map Text HistoricTestResult
-> TestHistory
TestHistory ([TestRunHistory] -> Vector TestRunHistory
forall a. [a] -> Vector a
V.fromList [TestRunHistory]
runs) ([TestRunHistory]
-> (HistoricTestResult -> Bool) -> Map Text HistoricTestResult
createIndex [TestRunHistory]
runs (Bool -> HistoricTestResult -> Bool
forall a b. a -> b -> a
const Bool
True)) ([TestRunHistory]
-> (HistoricTestResult -> Bool) -> Map Text HistoricTestResult
createIndex [TestRunHistory]
runs HistoricTestResult -> Bool
isSuccess)

-- The [TestRunHistory] list is sorted reverse chronologically
createIndex :: [TestRunHistory] -> (HistoricTestResult -> Bool) -> Map T.Text (HistoricTestResult)
createIndex :: [TestRunHistory]
-> (HistoricTestResult -> Bool) -> Map Text HistoricTestResult
createIndex [TestRunHistory]
list HistoricTestResult -> Bool
pred =
    (Map Text HistoricTestResult
 -> HistoricTestResult -> Map Text HistoricTestResult)
-> Map Text HistoricTestResult
-> [HistoricTestResult]
-> Map Text HistoricTestResult
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' Map Text HistoricTestResult
-> HistoricTestResult -> Map Text HistoricTestResult
updateMap Map Text HistoricTestResult
forall k a. Map k a
Map.empty [HistoricTestResult]
flatRunHistory
    where
      updateMap :: Map Text HistoricTestResult
-> HistoricTestResult -> Map Text HistoricTestResult
updateMap Map Text HistoricTestResult
m HistoricTestResult
res =
          (HistoricTestResult -> HistoricTestResult -> HistoricTestResult)
-> Text
-> HistoricTestResult
-> Map Text HistoricTestResult
-> Map Text HistoricTestResult
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (\HistoricTestResult
_new HistoricTestResult
old -> HistoricTestResult
old) (HistoricTestResult -> Text
htr_testId HistoricTestResult
res) HistoricTestResult
res Map Text HistoricTestResult
m
      flatRunHistory :: [HistoricTestResult]
flatRunHistory =
          (HistoricTestResult -> Bool)
-> [HistoricTestResult] -> [HistoricTestResult]
forall a. (a -> Bool) -> [a] -> [a]
filter HistoricTestResult -> Bool
pred ([HistoricTestResult] -> [HistoricTestResult])
-> [HistoricTestResult] -> [HistoricTestResult]
forall a b. (a -> b) -> a -> b
$ (TestRunHistory -> [HistoricTestResult])
-> [TestRunHistory] -> [HistoricTestResult]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\TestRunHistory
trh -> Vector HistoricTestResult -> [HistoricTestResult]
forall a. Vector a -> [a]
V.toList (TestRunHistory -> Vector HistoricTestResult
trh_tests TestRunHistory
trh)) [TestRunHistory]
list

findHistoricTestResult :: T.Text -> TestHistory -> Maybe (HistoricTestResult)
findHistoricTestResult :: Text -> TestHistory -> Maybe HistoricTestResult
findHistoricTestResult Text
id TestHistory
hist = Text -> Map Text HistoricTestResult -> Maybe HistoricTestResult
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
id (TestHistory -> Map Text HistoricTestResult
th_index TestHistory
hist)

findHistoricSuccessfulTestResult :: T.Text -> TestHistory -> Maybe (HistoricTestResult)
findHistoricSuccessfulTestResult :: Text -> TestHistory -> Maybe HistoricTestResult
findHistoricSuccessfulTestResult Text
id TestHistory
hist = Text -> Map Text HistoricTestResult -> Maybe HistoricTestResult
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
id (TestHistory -> Map Text HistoricTestResult
th_successfulIndex TestHistory
hist)

data SerializableTestHistory
    = SerializableTestHistory
      { SerializableTestHistory -> Int
sth_version :: Int
      , SerializableTestHistory -> Vector TestRunHistory
sth_runs :: !(V.Vector (TestRunHistory)) -- reverse chronologically sorted
      }

_CURRENT_VERSION_ :: Int
_CURRENT_VERSION_ :: Int
_CURRENT_VERSION_ = Int
0

instance ToJSON TestResult where
    toJSON :: TestResult -> Value
toJSON TestResult
r = Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$
        case TestResult -> [(TestResult, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup TestResult
r [(TestResult, Text)]
testResultStringMapping of
          Just Text
s -> Text
s
          Maybe Text
Nothing -> [Char] -> Text
forall a. HasCallStack => [Char] -> a
error ([Char]
"TestResult " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ TestResult -> [Char]
forall a. Show a => a -> [Char]
show TestResult
r [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" not defined in testResultStringMapping")

instance FromJSON TestResult where
    parseJSON :: Value -> Parser TestResult
parseJSON Value
v =
        case Value
v of
          String Text
s
              | Just TestResult
r <- Text -> [(Text, TestResult)] -> Maybe TestResult
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup Text
s (((TestResult, Text) -> (Text, TestResult))
-> [(TestResult, Text)] -> [(Text, TestResult)]
forall a b. (a -> b) -> [a] -> [b]
map (\(TestResult
x, Text
y) -> (Text
y, TestResult
x)) [(TestResult, Text)]
testResultStringMapping)
                       -> TestResult -> Parser TestResult
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return TestResult
r
          Value
_ -> [Char] -> Parser TestResult
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"could not parse JSON value as a test result: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> [Char]
forall a. Show a => a -> [Char]
show Value
v)

testResultStringMapping :: [(TestResult, T.Text)]
testResultStringMapping :: [(TestResult, Text)]
testResultStringMapping =
    [(TestResult
Pass, Text
"pass"), (TestResult
Pending, Text
"pending"), (TestResult
Fail, Text
"fail"), (TestResult
Error, Text
"error")]

deriveJSON (defaultOptions { fieldLabelModifier = drop 4 }) ''HistoricTestResult
deriveJSON (defaultOptions { fieldLabelModifier = drop 4 }) ''TestRunHistory
deriveJSON (defaultOptions { fieldLabelModifier = drop 4 }) ''SerializableTestHistory

serializeTestHistory :: TestHistory -> BS.ByteString
serializeTestHistory :: TestHistory -> ByteString
serializeTestHistory TestHistory
hist =
    let serHist :: SerializableTestHistory
serHist = SerializableTestHistory {
                    sth_version :: Int
sth_version = Int
_CURRENT_VERSION_
                  , sth_runs :: Vector TestRunHistory
sth_runs = TestHistory -> Vector TestRunHistory
th_runs TestHistory
hist
                  }
    in ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ SerializableTestHistory -> ByteString
forall a. ToJSON a => a -> ByteString
encode SerializableTestHistory
serHist

deserializeTestHistory :: BS.ByteString -> Either String (TestHistory)
deserializeTestHistory :: ByteString -> Either [Char] TestHistory
deserializeTestHistory ByteString
bs =
    -- assume version 0 for now. Later we have to look into the json, find the version and then decide which parser to user
    case ByteString -> Maybe SerializableTestHistory
forall a. FromJSON a => ByteString -> Maybe a
decodeStrict ByteString
bs of
      Maybe SerializableTestHistory
Nothing -> [Char] -> Either [Char] TestHistory
forall a b. a -> Either a b
Left ([Char]
"could not decode JSON: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
bs)
      Just !SerializableTestHistory
serHist ->
          let list :: [TestRunHistory]
list = Vector TestRunHistory -> [TestRunHistory]
forall a. Vector a -> [a]
V.toList (SerializableTestHistory -> Vector TestRunHistory
sth_runs SerializableTestHistory
serHist)
          in TestHistory -> Either [Char] TestHistory
forall a b. b -> Either a b
Right (Vector TestRunHistory
-> Map Text HistoricTestResult
-> Map Text HistoricTestResult
-> TestHistory
TestHistory (SerializableTestHistory -> Vector TestRunHistory
sth_runs SerializableTestHistory
serHist) ([TestRunHistory]
-> (HistoricTestResult -> Bool) -> Map Text HistoricTestResult
createIndex [TestRunHistory]
list (Bool -> HistoricTestResult -> Bool
forall a b. a -> b -> a
const Bool
True)) ([TestRunHistory]
-> (HistoricTestResult -> Bool) -> Map Text HistoricTestResult
createIndex [TestRunHistory]
list HistoricTestResult -> Bool
isSuccess))

testCreateIndex :: IO ()
testCreateIndex =
    do UTCTime
time <- IO UTCTime
getCurrentTime
       let index :: Map Text HistoricTestResult
index = [TestRunHistory]
-> (HistoricTestResult -> Bool) -> Map Text HistoricTestResult
createIndex (UTCTime -> [TestRunHistory]
historyList UTCTime
time) (Bool -> HistoricTestResult -> Bool
forall a b. a -> b -> a
const Bool
True)
       if Map Text HistoricTestResult
index Map Text HistoricTestResult -> Map Text HistoricTestResult -> Bool
forall a. Eq a => a -> a -> Bool
== Map Text HistoricTestResult
expectedIndex
       then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       else [Char] -> IO ()
forall a. HasCallStack => [Char] -> IO a
assertFailure ([Char]
"== Expected index:\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Map Text HistoricTestResult -> [Char]
forall a. Show a => a -> [Char]
show Map Text HistoricTestResult
expectedIndex [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                           [Char]
"\n== Given index:\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Map Text HistoricTestResult -> [Char]
forall a. Show a => a -> [Char]
show Map Text HistoricTestResult
index)
    where
      historyList :: UTCTime -> [TestRunHistory]
historyList UTCTime
time =
          [UTCTime -> [HistoricTestResult] -> TestRunHistory
mkHist UTCTime
time [Text -> Int -> HistoricTestResult
mkRes Text
"foo" Int
1]
          ,UTCTime -> [HistoricTestResult] -> TestRunHistory
mkHist UTCTime
time [Text -> Int -> HistoricTestResult
mkRes Text
"foo" Int
2, Text -> Int -> HistoricTestResult
mkRes Text
"bar" Int
10]
          ,UTCTime -> [HistoricTestResult] -> TestRunHistory
mkHist UTCTime
time [Text -> Int -> HistoricTestResult
mkRes Text
"bar" Int
20, Text -> Int -> HistoricTestResult
mkRes Text
"egg" Int
3]]
      expectedIndex :: Map Text HistoricTestResult
expectedIndex = [(Text, HistoricTestResult)] -> Map Text HistoricTestResult
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text
"foo", Text -> Int -> HistoricTestResult
mkRes Text
"foo" Int
1)
                                   ,(Text
"bar", Text -> Int -> HistoricTestResult
mkRes Text
"bar" Int
10)
                                   ,(Text
"egg", Text -> Int -> HistoricTestResult
mkRes Text
"egg" Int
3)]
      mkHist :: UTCTime -> [HistoricTestResult] -> TestRunHistory
mkHist UTCTime
time [HistoricTestResult]
l = UTCTime -> Vector HistoricTestResult -> TestRunHistory
TestRunHistory UTCTime
time ([HistoricTestResult] -> Vector HistoricTestResult
forall a. [a] -> Vector a
V.fromList [HistoricTestResult]
l)
      mkRes :: Text -> Int -> HistoricTestResult
mkRes Text
id Int
ms = Text -> TestResult -> Bool -> Int -> HistoricTestResult
HistoricTestResult Text
id TestResult
Pass Bool
False Int
ms

historyTests :: [([Char], IO ())]
historyTests = [([Char]
"testCreateIndex", IO ()
testCreateIndex)]