content: {-# LANGUAGE TemplateHaskell #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  {-| Unittests for @xl list --long@ parser -}
  
  {-
  
  Copyright (C) 2013 Google Inc.
  All rights reserved.
  
  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions are
  met:
  
  1. Redistributions of source code must retain the above copyright notice,
  this list of conditions and the following disclaimer.
  
  2. Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.
  
  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
  IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
  EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
  PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
  LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  
  -}
  
  module Test.Ganeti.Hypervisor.Xen.XlParser
    ( testHypervisor_Xen_XlParser
    ) where
  
  import Test.HUnit
  import Test.QuickCheck as QuickCheck hiding (Result)
  
  import Test.Ganeti.TestHelper
  import Test.Ganeti.TestCommon
  
  import Control.Monad (liftM)
  import qualified Data.Attoparsec.Text as A
  import Data.Text (pack)
  import Data.Char
  import qualified Data.Map as Map
  import Text.Printf
  
  import Ganeti.Hypervisor.Xen.Types
  import Ganeti.Hypervisor.Xen.XlParser
  
  {-# ANN module "HLint: ignore Use camelCase" #-}
  
  -- * Arbitraries
  
  -- | Generator for 'ListConfig'.
  --
  -- A completely arbitrary configuration would contain too many lists
  -- and its size would be to big to be actually parsable in reasonable
  -- time. This generator builds a random Config that is still of a
  -- reasonable size, and it also Avoids generating strings that might
  -- be interpreted as numbers.
  genConfig :: Int -> Gen LispConfig
  genConfig 0 =
    -- only terminal values for size 0
    frequency [ (5, liftM LCString (genName `suchThat` (not . canBeNumber)))
              , (5, liftM LCDouble arbitrary)
              ]
  genConfig n =
    -- for size greater than 0, allow "some" lists
    frequency [ (5, liftM LCString (resize n genName `suchThat`
                                    (not . canBeNumber)))
              , (5, liftM LCDouble arbitrary)
              , (1, liftM LCList (choose (1, n) >>=
                                  (\n' -> vectorOf n' (genConfig $ n `div` n'))))
              ]
  
  -- | Arbitrary instance for 'LispConfig' using 'genConfig'.
  instance Arbitrary LispConfig where
    arbitrary = sized genConfig
  
  -- | Determines conservatively whether a string could be a number.
  canBeNumber :: String -> Bool
  canBeNumber [] = False
  canBeNumber [c] = canBeNumberChar c
  canBeNumber (c:xs) = canBeNumberChar c && canBeNumber xs
  
  -- | Determines whether a char can be part of the string representation of a
  -- number (even in scientific notation).
  canBeNumberChar :: Char -> Bool
  canBeNumberChar c = isDigit c || (c `elem` "eE-")
  
  -- | Generates an arbitrary @xl uptime@ output line.
  instance Arbitrary UptimeInfo where
    arbitrary = do
      name <- genFQDN
      NonNegative idNum <- arbitrary :: Gen (NonNegative Int)
      NonNegative days <- arbitrary :: Gen (NonNegative Int)
      hours <- choose (0, 23) :: Gen Int
      mins <- choose (0, 59) :: Gen Int
      secs <- choose (0, 59) :: Gen Int
      let uptime :: String
          uptime =
            if days /= 0
              then printf "%d days, %d:%d:%d" days hours mins secs
              else printf "%d:%d:%d" hours mins secs
      return $ UptimeInfo name idNum uptime
  
  -- * Helper functions for tests
  
  -- | Function for testing whether a domain configuration is parsed correctly.
  testDomain :: String -> Map.Map String Domain -> Assertion
  testDomain fileName expectedContent = do
    fileContent <- readTestData fileName
    case A.parseOnly xlListParser $ pack fileContent of
      Left msg -> assertFailure $ "Parsing failed: " ++ msg
      Right obtained -> assertEqual fileName expectedContent obtained
  
  -- | Function for testing whether a @xl uptime@ output (stored in a file)
  -- is parsed correctly.
  testUptimeInfo :: String -> Map.Map Int UptimeInfo -> Assertion
  testUptimeInfo fileName expectedContent = do
    fileContent <- readTestData fileName
    case A.parseOnly xlUptimeParser $ pack fileContent of
      Left msg -> assertFailure $ "Parsing failed: " ++ msg
      Right obtained -> assertEqual fileName expectedContent obtained
  
  -- | Determines whether two LispConfig are equal, with the exception of Double
  -- values, that just need to be \"almost equal\".
  --
  -- Meant mainly for testing purposes, given that Double values may be slightly
  -- rounded during parsing.
  isAlmostEqual :: LispConfig -> LispConfig -> Property
  isAlmostEqual (LCList c1) (LCList c2) =
    (length c1 ==? length c2) .&&.
    conjoin (zipWith isAlmostEqual c1 c2)
  isAlmostEqual (LCString s1) (LCString s2) = s1 ==? s2
  isAlmostEqual (LCDouble d1) (LCDouble d2) = counterexample msg $ rel <= 1e-12
      where rel = relativeError d1 d2
            msg = "Relative error " ++ show rel ++ " not smaller than 1e-12\n" ++
                  "expected: " ++ show d2 ++ "\n but got: " ++ show d1
  isAlmostEqual a b =
    failTest $ "Comparing different types: '" ++ show a ++ "' with '" ++
               show b ++ "'"
  
  -- | Function to serialize LispConfigs in such a way that they can be rebuilt
  -- again by the lispConfigParser.
  serializeConf :: LispConfig -> String
  serializeConf (LCList c) = "(" ++ unwords (map serializeConf c) ++ ")"
  serializeConf (LCString s) = s
  serializeConf (LCDouble d) = show d
  
  -- | Function to serialize UptimeInfos in such a way that they can be rebuilt
  -- againg by the uptimeLineParser.
  serializeUptime :: UptimeInfo -> String
  serializeUptime (UptimeInfo name idNum uptime) =
    printf "%s\t%d\t%s" name idNum uptime
  
  -- | Test whether a randomly generated config can be parsed.
  -- Implicitly, this also tests that the Show instance of Config is correct.
  prop_config :: LispConfig -> Property
  prop_config conf =
    case A.parseOnly lispConfigParser . pack . serializeConf $ conf of
          Left msg -> failTest $ "Parsing failed: " ++ msg
          Right obtained -> counterexample "Failing almost equal check" $
                            isAlmostEqual obtained conf
  
  -- | Test whether a randomly generated UptimeInfo text line can be parsed.
  prop_uptimeInfo :: UptimeInfo -> Property
  prop_uptimeInfo uInfo =
    case A.parseOnly uptimeLineParser . pack . serializeUptime $ uInfo of
      Left msg -> failTest $ "Parsing failed: " ++ msg
      Right obtained -> obtained ==? uInfo
  
  -- | Test a Xen 4.0.1 @xl list --long@ output.
  case_xen401list :: Assertion
  case_xen401list = testDomain "xen-xl-list-long-4.0.1.txt" $
    Map.fromList
      [ ("Domain-0", Domain 0 "Domain-0" 184000.41332 ActualRunning Nothing)
      , ("instance1.example.com", Domain 119 "instance1.example.com" 24.116146647
        ActualBlocked Nothing)
      ]
  
  -- | Test a Xen 4.0.1 @xl uptime@ output.
  case_xen401uptime :: Assertion
  case_xen401uptime = testUptimeInfo "xen-xl-uptime-4.0.1.txt" $
    Map.fromList
      [ (0, UptimeInfo "Domain-0" 0 "98 days,  2:27:44")
      , (119, UptimeInfo "instance1.example.com" 119 "15 days, 20:57:07")
      ]
  
  testSuite "Hypervisor/Xen/XlParser"
            [ 'prop_config
            , 'prop_uptimeInfo
            , 'case_xen401list
            , 'case_xen401uptime
            ]
  