{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances,
  OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

{-| Unittests for ganeti-htools.

-}

{-

Copyright (C) 2009, 2010, 2011, 2012, 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.Objects
  ( testObjects
  , Node(..)
  , genConfigDataWithNetworks
  , genDisk
  , genDiskWithChildren
  , genEmptyCluster
  , genInst
  , genInstWithNets
  , genValidNetwork
  , genBitStringMaxLen
  ) where

import Test.QuickCheck
import qualified Test.HUnit as HUnit

import Control.Applicative
import Control.Monad
import Data.Char
import qualified Data.List as List
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set
import GHC.Exts (IsString(..))
import qualified Text.JSON as J

import Test.Ganeti.TestHelper
import Test.Ganeti.TestCommon
import Test.Ganeti.Types ()

import qualified Ganeti.Constants as C
import Ganeti.Network
import Ganeti.Objects as Objects
import Ganeti.JSON
import Ganeti.Types

-- * Arbitrary instances

$(genArbitrary ''PartialNDParams)

instance Arbitrary Node where
  arbitrary = Node <$> genFQDN <*> genFQDN <*> genFQDN
              <*> arbitrary <*> arbitrary <*> arbitrary <*> genFQDN
              <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
              <*> arbitrary <*> arbitrary <*> genFQDN <*> arbitrary
              <*> (Set.fromList <$> genTags)

$(genArbitrary ''BlockDriver)

$(genArbitrary ''DiskMode)

instance Arbitrary DiskLogicalId where
  arbitrary = oneof [ LIDPlain <$> arbitrary <*> arbitrary
                    , LIDDrbd8 <$> genFQDN <*> genFQDN <*> arbitrary
                               <*> arbitrary <*> arbitrary <*> arbitrary
                    , LIDFile  <$> arbitrary <*> arbitrary
                    , LIDBlockDev <$> arbitrary <*> arbitrary
                    , LIDRados <$> arbitrary <*> arbitrary
                    ]

-- | 'Disk' 'arbitrary' instance. Since we don't test disk hierarchy
-- properties, we only generate disks with no children (FIXME), as
-- generating recursive datastructures is a bit more work.
instance Arbitrary Disk where
  arbitrary = Disk <$> arbitrary <*> pure [] <*> arbitrary
                   <*> arbitrary <*> arbitrary <*> arbitrary
                   <*> arbitrary <*> arbitrary

-- FIXME: we should generate proper values, >=0, etc., but this is
-- hard for partial ones, where all must be wrapped in a 'Maybe'
$(genArbitrary ''PartialBeParams)

$(genArbitrary ''AdminState)

$(genArbitrary ''AdminStateSource)

$(genArbitrary ''PartialNicParams)

$(genArbitrary ''PartialNic)

instance Arbitrary Instance where
  arbitrary =
    Instance
      -- name
      <$> genFQDN
      -- primary node
      <*> genFQDN
      -- OS
      <*> genFQDN
      -- hypervisor
      <*> arbitrary
      -- hvparams
      -- FIXME: add non-empty hvparams when they're a proper type
      <*> pure (GenericContainer Map.empty)
      -- beparams
      <*> arbitrary
      -- osparams
      <*> pure (GenericContainer Map.empty)
      -- admin_state
      <*> arbitrary
      -- admin_state_source
      <*> arbitrary
      -- nics
      <*> arbitrary
      -- disks
      <*> vectorOf 5 genDisk
      -- disk template
      <*> arbitrary
      -- disks active
      <*> arbitrary
      -- network port
      <*> arbitrary
      -- ts
      <*> arbitrary <*> arbitrary
      -- uuid
      <*> arbitrary
      -- serial
      <*> arbitrary
      -- tags
      <*> (Set.fromList <$> genTags)

-- | Generates an instance that is connected to the given networks
-- and possibly some other networks
genInstWithNets :: [String] -> Gen Instance
genInstWithNets nets = do
  plain_inst <- arbitrary
  enhanceInstWithNets plain_inst nets

-- | Generates an instance that is connected to some networks
genInst :: Gen Instance
genInst = genInstWithNets []

-- | Enhances a given instance with network information, by connecting it to the
-- given networks and possibly some other networks
enhanceInstWithNets :: Instance -> [String] -> Gen Instance
enhanceInstWithNets inst nets = do
  mac <- arbitrary
  ip <- arbitrary
  nicparams <- arbitrary
  name <- arbitrary
  uuid <- arbitrary
  -- generate some more networks than the given ones
  num_more_nets <- choose (0,3)
  more_nets <- vectorOf num_more_nets genUUID
  let genNic net = PartialNic mac ip nicparams net name uuid
      partial_nics = map (genNic . Just)
                         (List.nub (nets ++ more_nets))
      new_inst = inst { instNics = partial_nics }
  return new_inst

genDiskWithChildren :: Int -> Gen Disk
genDiskWithChildren num_children = do
  logicalid <- arbitrary
  children <- vectorOf num_children (genDiskWithChildren 0)
  ivname <- genName
  size <- arbitrary
  mode <- arbitrary
  name <- genMaybe genName
  spindles <- arbitrary
  uuid <- genName
  let disk = Disk logicalid children ivname size mode name spindles uuid
  return disk

genDisk :: Gen Disk
genDisk = genDiskWithChildren 3

-- | FIXME: This generates completely random data, without normal
-- validation rules.
$(genArbitrary ''PartialISpecParams)

-- | FIXME: This generates completely random data, without normal
-- validation rules.
$(genArbitrary ''PartialIPolicy)

$(genArbitrary ''FilledISpecParams)
$(genArbitrary ''MinMaxISpecs)
$(genArbitrary ''FilledIPolicy)
$(genArbitrary ''IpFamily)
$(genArbitrary ''FilledNDParams)
$(genArbitrary ''FilledNicParams)
$(genArbitrary ''FilledBeParams)

-- | No real arbitrary instance for 'ClusterHvParams' yet.
instance Arbitrary ClusterHvParams where
  arbitrary = return $ GenericContainer Map.empty

-- | No real arbitrary instance for 'OsHvParams' yet.
instance Arbitrary OsHvParams where
  arbitrary = return $ GenericContainer Map.empty

instance Arbitrary ClusterNicParams where
  arbitrary = (GenericContainer . Map.singleton C.ppDefault) <$> arbitrary

instance Arbitrary OsParams where
  arbitrary = (GenericContainer . Map.fromList) <$> arbitrary

instance Arbitrary ClusterOsParams where
  arbitrary = (GenericContainer . Map.fromList) <$> arbitrary

instance Arbitrary ClusterBeParams where
  arbitrary = (GenericContainer . Map.fromList) <$> arbitrary

instance Arbitrary TagSet where
  arbitrary = Set.fromList <$> genTags

instance Arbitrary IAllocatorParams where
  arbitrary = return $ GenericContainer Map.empty

$(genArbitrary ''Cluster)

instance Arbitrary Network where
  arbitrary = genValidNetwork

-- | Generates a network instance with minimum netmasks of /24. Generating
-- bigger networks slows down the tests, because long bit strings are generated
-- for the reservations.
genValidNetwork :: Gen Objects.Network
genValidNetwork = do
  -- generate netmask for the IPv4 network
  netmask <- fromIntegral <$> choose (24::Int, 30)
  name <- genName >>= mkNonEmpty
  mac_prefix <- genMaybe genName
  net <- arbitrary
  net6 <- genMaybe genIp6Net
  gateway <- genMaybe arbitrary
  gateway6 <- genMaybe genIp6Addr
  res <- liftM Just (genBitString $ netmask2NumHosts netmask)
  ext_res <- liftM Just (genBitString $ netmask2NumHosts netmask)
  uuid <- arbitrary
  ctime <- arbitrary
  mtime <- arbitrary
  let n = Network name mac_prefix (Ip4Network net netmask) net6 gateway
          gateway6 res ext_res uuid ctime mtime 0 Set.empty
  return n

-- | Generate an arbitrary string consisting of '0' and '1' of the given length.
genBitString :: Int -> Gen String
genBitString len = vectorOf len (elements "01")

-- | Generate an arbitrary string consisting of '0' and '1' of the maximum given
-- length.
genBitStringMaxLen :: Int -> Gen String
genBitStringMaxLen maxLen = choose (0, maxLen) >>= genBitString

-- | Generator for config data with an empty cluster (no instances),
-- with N defined nodes.
genEmptyCluster :: Int -> Gen ConfigData
genEmptyCluster ncount = do
  nodes <- vector ncount
  version <- arbitrary
  grp <- arbitrary
  let guuid = groupUuid grp
      nodes' = zipWith (\n idx ->
                          let newname = takeWhile (/= '.') (nodeName n)
                                        ++ "-" ++ show idx
                          in (newname, n { nodeGroup = guuid,
                                           nodeName = newname}))
               nodes [(1::Int)..]
      nodemap = Map.fromList nodes'
      contnodes = if Map.size nodemap /= ncount
                    then error ("Inconsistent node map, duplicates in" ++
                                " node name list? Names: " ++
                                show (map fst nodes'))
                    else GenericContainer nodemap
      continsts = GenericContainer Map.empty
      networks = GenericContainer Map.empty
  let contgroups = GenericContainer $ Map.singleton guuid grp
  serial <- arbitrary
  cluster <- resize 8 arbitrary
  let c = ConfigData version cluster contnodes contgroups continsts networks
            serial
  return c

-- | FIXME: make an even simpler base version of creating a cluster.

-- | Generates config data with a couple of networks.
genConfigDataWithNetworks :: ConfigData -> Gen ConfigData
genConfigDataWithNetworks old_cfg = do
  num_nets <- choose (0, 3)
  -- generate a list of network names (no duplicates)
  net_names <- genUniquesList num_nets genName >>= mapM mkNonEmpty
  -- generate a random list of networks (possibly with duplicate names)
  nets <- vectorOf num_nets genValidNetwork
  -- use unique names for the networks
  let nets_unique = map ( \(name, net) -> net { networkName = name } )
        (zip net_names nets)
      net_map = GenericContainer $ Map.fromList
        (map (\n -> (networkUuid n, n)) nets_unique)
      new_cfg = old_cfg { configNetworks = net_map }
  return new_cfg

-- * Test properties

-- | Tests that fillDict behaves correctly
prop_fillDict :: [(Int, Int)] -> [(Int, Int)] -> Property
prop_fillDict defaults custom =
  let d_map = Map.fromList defaults
      d_keys = map fst defaults
      c_map = Map.fromList custom
      c_keys = map fst custom
  in conjoin [ printTestCase "Empty custom filling"
               (fillDict d_map Map.empty [] == d_map)
             , printTestCase "Empty defaults filling"
               (fillDict Map.empty c_map [] == c_map)
             , printTestCase "Delete all keys"
               (fillDict d_map c_map (d_keys++c_keys) == Map.empty)
             ]

-- | Test that the serialisation of 'DiskLogicalId', which is
-- implemented manually, is idempotent. Since we don't have a
-- standalone JSON instance for DiskLogicalId (it's a data type that
-- expands over two fields in a JSObject), we test this by actially
-- testing entire Disk serialisations. So this tests two things at
-- once, basically.
prop_Disk_serialisation :: Disk -> Property
prop_Disk_serialisation = testSerialisation

-- | Check that node serialisation is idempotent.
prop_Node_serialisation :: Node -> Property
prop_Node_serialisation = testSerialisation

-- | Check that instance serialisation is idempotent.
prop_Inst_serialisation :: Instance -> Property
prop_Inst_serialisation = testSerialisation

-- | Check that network serialisation is idempotent.
prop_Network_serialisation :: Network -> Property
prop_Network_serialisation = testSerialisation

-- | Check config serialisation.
prop_Config_serialisation :: Property
prop_Config_serialisation =
  forAll (choose (0, maxNodes `div` 4) >>= genEmptyCluster) testSerialisation

-- | Custom HUnit test to check the correspondence between Haskell-generated
-- networks and their Python decoded, validated and re-encoded version.
-- For the technical background of this unit test, check the documentation
-- of "case_py_compat_types" of test/hs/Test/Ganeti/Opcodes.hs
casePyCompatNetworks :: HUnit.Assertion
casePyCompatNetworks = do
  let num_networks = 500::Int
  networks <- genSample (vectorOf num_networks genValidNetwork)
  let networks_with_properties = map getNetworkProperties networks
      serialized = J.encode networks
  -- check for non-ASCII fields, usually due to 'arbitrary :: String'
  mapM_ (\net -> when (any (not . isAscii) (J.encode net)) .
                 HUnit.assertFailure $
                 "Network has non-ASCII fields: " ++ show net
        ) networks
  py_stdout <-
    runPython "from ganeti import network\n\
              \from ganeti import objects\n\
              \from ganeti import serializer\n\
              \import sys\n\
              \net_data = serializer.Load(sys.stdin.read())\n\
              \decoded = [objects.Network.FromDict(n) for n in net_data]\n\
              \encoded = []\n\
              \for net in decoded:\n\
              \  a = network.AddressPool(net)\n\
              \  encoded.append((a.GetFreeCount(), a.GetReservedCount(), \\\n\
              \    net.ToDict()))\n\
              \print serializer.Dump(encoded)" serialized
    >>= checkPythonResult
  let deserialised = J.decode py_stdout::J.Result [(Int, Int, Network)]
  decoded <- case deserialised of
               J.Ok ops -> return ops
               J.Error msg ->
                 HUnit.assertFailure ("Unable to decode networks: " ++ msg)
                 -- this already raised an expection, but we need it
                 -- for proper types
                 >> fail "Unable to decode networks"
  HUnit.assertEqual "Mismatch in number of returned networks"
    (length decoded) (length networks_with_properties)
  mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
        ) $ zip decoded networks_with_properties

-- | Creates a tuple of the given network combined with some of its properties
-- to be compared against the same properties generated by the python code.
getNetworkProperties :: Network -> (Int, Int, Network)
getNetworkProperties net =
  let maybePool = createAddressPool net
  in  case maybePool of
           (Just pool) -> (getFreeCount pool, getReservedCount pool, net)
           Nothing -> (-1, -1, net)

-- | Tests the compatibility between Haskell-serialized node groups and their
-- python-decoded and encoded version.
casePyCompatNodegroups :: HUnit.Assertion
casePyCompatNodegroups = do
  let num_groups = 500::Int
  groups <- genSample (vectorOf num_groups genNodeGroup)
  let serialized = J.encode groups
  -- check for non-ASCII fields, usually due to 'arbitrary :: String'
  mapM_ (\group -> when (any (not . isAscii) (J.encode group)) .
                 HUnit.assertFailure $
                 "Node group has non-ASCII fields: " ++ show group
        ) groups
  py_stdout <-
    runPython "from ganeti import objects\n\
              \from ganeti import serializer\n\
              \import sys\n\
              \group_data = serializer.Load(sys.stdin.read())\n\
              \decoded = [objects.NodeGroup.FromDict(g) for g in group_data]\n\
              \encoded = [g.ToDict() for g in decoded]\n\
              \print serializer.Dump(encoded)" serialized
    >>= checkPythonResult
  let deserialised = J.decode py_stdout::J.Result [NodeGroup]
  decoded <- case deserialised of
               J.Ok ops -> return ops
               J.Error msg ->
                 HUnit.assertFailure ("Unable to decode node groups: " ++ msg)
                 -- this already raised an expection, but we need it
                 -- for proper types
                 >> fail "Unable to decode node groups"
  HUnit.assertEqual "Mismatch in number of returned node groups"
    (length decoded) (length groups)
  mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
        ) $ zip decoded groups

-- | Generates a node group with up to 3 networks.
-- | FIXME: This generates still somewhat completely random data, without normal
-- validation rules.
genNodeGroup :: Gen NodeGroup
genNodeGroup = do
  name <- genFQDN
  members <- pure []
  ndparams <- arbitrary
  alloc_policy <- arbitrary
  ipolicy <- arbitrary
  diskparams <- pure (GenericContainer Map.empty)
  num_networks <- choose (0, 3)
  net_uuid_list <- vectorOf num_networks (arbitrary::Gen String)
  nic_param_list <- vectorOf num_networks (arbitrary::Gen PartialNicParams)
  net_map <- pure (GenericContainer . Map.fromList $
    zip net_uuid_list nic_param_list)
  -- timestamp fields
  ctime <- arbitrary
  mtime <- arbitrary
  uuid <- genFQDN `suchThat` (/= name)
  serial <- arbitrary
  tags <- Set.fromList <$> genTags
  let group = NodeGroup name members ndparams alloc_policy ipolicy diskparams
              net_map ctime mtime uuid serial tags
  return group

instance Arbitrary NodeGroup where
  arbitrary = genNodeGroup

$(genArbitrary ''Ip4Address)

$(genArbitrary ''Ip4Network)

-- | Helper to compute absolute value of an IPv4 address.
ip4AddrValue :: Ip4Address -> Integer
ip4AddrValue (Ip4Address a b c d) =
  fromIntegral a * (2^(24::Integer)) +
  fromIntegral b * (2^(16::Integer)) +
  fromIntegral c * (2^(8::Integer)) + fromIntegral d

-- | Tests that any difference between IPv4 consecutive addresses is 1.
prop_nextIp4Address :: Ip4Address -> Property
prop_nextIp4Address ip4 =
  ip4AddrValue (nextIp4Address ip4) ==? ip4AddrValue ip4 + 1

-- | IsString instance for 'Ip4Address', to help write the tests.
instance IsString Ip4Address where
  fromString s =
    fromMaybe (error $ "Failed to parse address from " ++ s) (readIp4Address s)

-- | Tests a few simple cases of IPv4 next address.
caseNextIp4Address :: HUnit.Assertion
caseNextIp4Address = do
  HUnit.assertEqual "" "0.0.0.1" $ nextIp4Address "0.0.0.0"
  HUnit.assertEqual "" "0.0.0.0" $ nextIp4Address "255.255.255.255"
  HUnit.assertEqual "" "1.2.3.5" $ nextIp4Address "1.2.3.4"
  HUnit.assertEqual "" "1.3.0.0" $ nextIp4Address "1.2.255.255"
  HUnit.assertEqual "" "1.2.255.63" $ nextIp4Address "1.2.255.62"

-- | Tests the compatibility between Haskell-serialized instances and their
-- python-decoded and encoded version.
-- Note: this can be enhanced with logical validations on the decoded objects
casePyCompatInstances :: HUnit.Assertion
casePyCompatInstances = do
  let num_inst = 500::Int
  instances <- genSample (vectorOf num_inst genInst)
  let serialized = J.encode instances
  -- check for non-ASCII fields, usually due to 'arbitrary :: String'
  mapM_ (\inst -> when (any (not . isAscii) (J.encode inst)) .
                 HUnit.assertFailure $
                 "Instance has non-ASCII fields: " ++ show inst
        ) instances
  py_stdout <-
    runPython "from ganeti import objects\n\
              \from ganeti import serializer\n\
              \import sys\n\
              \inst_data = serializer.Load(sys.stdin.read())\n\
              \decoded = [objects.Instance.FromDict(i) for i in inst_data]\n\
              \encoded = [i.ToDict() for i in decoded]\n\
              \print serializer.Dump(encoded)" serialized
    >>= checkPythonResult
  let deserialised = J.decode py_stdout::J.Result [Instance]
  decoded <- case deserialised of
               J.Ok ops -> return ops
               J.Error msg ->
                 HUnit.assertFailure ("Unable to decode instance: " ++ msg)
                 -- this already raised an expection, but we need it
                 -- for proper types
                 >> fail "Unable to decode instances"
  HUnit.assertEqual "Mismatch in number of returned instances"
    (length decoded) (length instances)
  mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
        ) $ zip decoded instances

-- | Tests that the logical ID is correctly found in a plain disk
caseIncludeLogicalIdPlain :: HUnit.Assertion
caseIncludeLogicalIdPlain =
  let vg_name = "xenvg" :: String
      lv_name = "1234sdf-qwef-2134-asff-asd2-23145d.data" :: String
      d =
        Disk (LIDPlain vg_name lv_name) [] "diskname" 1000 DiskRdWr
          Nothing Nothing "asdfgr-1234-5123-daf3-sdfw-134f43"
  in
    HUnit.assertBool "Unable to detect that plain Disk includes logical ID" $
      includesLogicalId vg_name lv_name d

-- | Tests that the logical ID is correctly found in a DRBD disk
caseIncludeLogicalIdDrbd :: HUnit.Assertion
caseIncludeLogicalIdDrbd =
  let vg_name = "xenvg" :: String
      lv_name = "1234sdf-qwef-2134-asff-asd2-23145d.data" :: String
      d = 
        Disk
          (LIDDrbd8 "node1.example.com" "node2.example.com" 2000 1 5 "secret")
          [ Disk (LIDPlain "onevg" "onelv") [] "disk1" 1000 DiskRdWr Nothing
              Nothing "145145-asdf-sdf2-2134-asfd-534g2x"
          , Disk (LIDPlain vg_name lv_name) [] "disk2" 1000 DiskRdWr Nothing
              Nothing "6gd3sd-423f-ag2j-563b-dg34-gj3fse"
          ] "diskname" 1000 DiskRdWr Nothing Nothing
          "asdfgr-1234-5123-daf3-sdfw-134f43"
  in
    HUnit.assertBool "Unable to detect that plain Disk includes logical ID" $
      includesLogicalId vg_name lv_name d

-- | Tests that the logical ID is correctly NOT found in a plain disk
caseNotIncludeLogicalIdPlain :: HUnit.Assertion
caseNotIncludeLogicalIdPlain =
  let vg_name = "xenvg" :: String
      lv_name = "1234sdf-qwef-2134-asff-asd2-23145d.data" :: String
      d =
        Disk (LIDPlain "othervg" "otherlv") [] "diskname" 1000 DiskRdWr
          Nothing Nothing "asdfgr-1234-5123-daf3-sdfw-134f43"
  in
    HUnit.assertBool "Unable to detect that plain Disk includes logical ID" $
      not (includesLogicalId vg_name lv_name d)

testSuite "Objects"
  [ 'prop_fillDict
  , 'prop_Disk_serialisation
  , 'prop_Inst_serialisation
  , 'prop_Network_serialisation
  , 'prop_Node_serialisation
  , 'prop_Config_serialisation
  , 'casePyCompatNetworks
  , 'casePyCompatNodegroups
  , 'casePyCompatInstances
  , 'prop_nextIp4Address
  , 'caseNextIp4Address
  , 'caseIncludeLogicalIdPlain
  , 'caseIncludeLogicalIdDrbd
  , 'caseNotIncludeLogicalIdPlain
  ]