code.delx.au - offlineimap/blob - testsrc/runtests.hs

   1 {-
   2 Copyright (C) 2002-2008 John Goerzen <jgoerzen@complete.org>
   3
   4 This program is free software; you can redistribute it and/or modify
   5 it under the terms of the GNU General Public License as published by
   6 the Free Software Foundation; either version 2 of the License, or
   7 (at your option) any later version.
   8
   9 This program is distributed in the hope that it will be useful,
  10 but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 GNU General Public License for more details.
  13
  14 You should have received a copy of the GNU General Public License
  15 along with this program; if not, write to the Free Software
  16 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17 -}
  18
  19 module Main where
  20 import Test.QuickCheck
  21 import Test.QuickCheck.Batch
  22 import qualified Test.HUnit as HU
  23 import Test.HUnit.Utils
  24 import qualified Data.Map as Map
  25 import Data.List
  26 import Data.Maybe(catMaybes)
  27 import System.IO(stderr)
  28 import Data.Word
  29
  30 import Data.Syncable
  31 import TestInfrastructure
  32
  33 prop_empty :: Bool
  34 prop_empty =
  35     syncBiDir (emptymap::Map.Map Int ()) emptymap emptymap == ([], []) -- ([DeleteItem 5], [], [])
  36
  37 prop_delAllFromChild :: SyncCollection Int () -> Result
  38 prop_delAllFromChild inp =
  39     let (resMaster, resChild) = syncBiDir emptymap inp inp
  40         expectedResChild = sort . map DeleteItem . Map.keys $ inp
  41         in ([], expectedResChild) @=?
  42            (resMaster, sort resChild)
  43
  44 prop_delAllFromMaster :: SyncCollection Int () -> Result
  45 prop_delAllFromMaster inp =
  46     let (resMaster, resChild) = syncBiDir inp emptymap inp
  47         expectedResMaster = sort . map DeleteItem . Map.keys $ inp
  48         in (expectedResMaster, []) @=?
  49            (sort resMaster, resChild)
  50
  51 prop_addFromMaster :: SyncCollection Int Word8 -> Result
  52 prop_addFromMaster inp =
  53     let (resMaster, resChild) = syncBiDir inp emptymap emptymap
  54         expectedResChild = sort . map (\(k, v) -> CopyItem k v) . Map.toList $ inp
  55         in ([], expectedResChild) @=?
  56            (resMaster, sort resChild)
  57
  58 -- FIXME: prop_addFromChild
  59
  60 prop_allChangesToChild :: SyncCollection Int Word8 -> SyncCollection Int Word8 -> Result
  61 prop_allChangesToChild master child =
  62     let (resMaster, resChild) = syncBiDir master child child
  63         expectedResChild = sort $
  64             (map (\(k, v) -> CopyItem k v) . Map.toList . Map.difference master $ child) ++
  65             (map DeleteItem . Map.keys . Map.difference child $ master) ++
  66             (map (pairToFunc ModifyContent) changeList)
  67         changeList = foldl changefunc [] (Map.toList child)
  68         changefunc accum (k, v) =
  69             case Map.lookup k master of
  70               Nothing -> accum
  71               Just x -> if x /= v
  72                         then (k, x) : accum
  73                         else accum
  74         in ([], expectedResChild) @=?
  75            (sort resMaster, sort resChild)
  76
  77 prop_allChangesToMaster :: SyncCollection Int Word8 -> SyncCollection Int Word8 -> Result
  78 prop_allChangesToMaster master child =
  79     let (resMaster, resChild) = syncBiDir master child master
  80         expectedResMaster = sort $
  81             (map (pairToFunc CopyItem) . Map.toList . Map.difference child $ master) ++
  82             (map DeleteItem . Map.keys . Map.difference master $ child) ++
  83             (map (pairToFunc ModifyContent) changeList)
  84         changeList = foldl changefunc [] (Map.toList child)
  85         changefunc accum (k, v) =
  86             case Map.lookup k master of
  87               Nothing -> accum
  88               Just x -> if x /= v
  89                         then (k, v) : accum
  90                         else accum
  91         in (expectedResMaster, []) @=?
  92            (sort resMaster, resChild)
  93
  94 -- FIXME: test findModified
  95
  96 prop_allChanges :: SyncCollection Int Word8 -> SyncCollection Int Word8 -> SyncCollection Int Word8 -> Result
  97 prop_allChanges master child lastchild =
  98     let (resMaster, resChild) = syncBiDir master child lastchild
  99
 100         masterMods = catMaybes . map procKV $ (Map.toList master)
 101             where procKV (k, m) =
 102                       case (Map.lookup k child, Map.lookup k lastchild) of
 103                         (Just c, Just lc) ->
 104                             if c == lc -- child didn't change
 105                                then Nothing
 106                                else if c == m -- child and master changed
 107                                     then Nothing
 108                                     else Just (k, c) -- child changed, master didn't
 109                         (Nothing, Just lc) -> Nothing -- deleted on child
 110                         (Just c, Nothing) -> -- New on both c and m
 111                             if c == m        -- Added the same
 112                                then Nothing
 113                                else Just (k, c) -- Added but differ
 114                         (Nothing, Nothing) -> Nothing -- New to master only
 115
 116         childMods = catMaybes . map procKV $ (Map.toList child)
 117             where procKV (k, c) =
 118                       case (Map.lookup k master, Map.lookup k lastchild) of
 119                         (Just m, Just lc) ->
 120                             if lc == c
 121                                then if c == m
 122                                        then Nothing
 123                                        else Just (k, m)
 124                                else Nothing
 125                         (Nothing, Just lc) ->        -- deleted; nothing to see here
 126                                               Nothing
 127                         (Just m, Nothing) -> -- New on both; child takes precedence
 128                            Nothing
 129                         (Nothing, Nothing) -> Nothing -- New to child only
 130
 131         expectedResMaster = sort $
 132             (map (pairToFunc CopyItem) . Map.toList . Map.difference child $ Map.union master lastchild) ++
 133                                                                                             (map DeleteItem . Map.keys . Map.intersection master $ Map.difference lastchild child) ++
 134             (map (pairToFunc ModifyContent) masterMods)
 135
 136         expectedResChild = sort $
 137             (map (pairToFunc CopyItem) . Map.toList . Map.difference master $ Map.union child lastchild) ++
 138                                                                                             (map DeleteItem . Map.keys . Map.intersection child $ Map.difference lastchild master) ++
 139             (map (pairToFunc ModifyContent) childMods)
 140
 141     in (expectedResMaster, expectedResChild) @=?
 142        (sort resMaster, sort resChild)
 143
 144 {- | Basic validation that unaryApplyChanges works -}
 145 prop_unaryApplyChanges :: SyncCollection Int Word8 -> [(Bool, Int, Word8)] -> Result
 146 prop_unaryApplyChanges collection randcommands =
 147     let -- We use nubBy to make sure we don't get input that has reference
 148         -- to the same key more than once.  We then convert True/False to
 149         -- commands.
 150         commands = map toCommand . nubBy (\(x1, y1, z1) (x2, y2, z2) -> y1 == y2) $ randcommands
 151         toCommand (True, x, v) = CopyItem x v
 152         toCommand (False, x, _) = DeleteItem x
 153
 154         addedItems = catMaybes . map (\x -> case x of CopyItem y v -> Just (y, v); _ -> Nothing) $ commands
 155         deletedKeys = catMaybes . map (\x -> case x of DeleteItem y -> Just y; _ -> Nothing) $ commands
 156
 157         collection' = foldl (flip Map.delete) collection deletedKeys
 158         expectedCollection =
 159             Map.union collection' (Map.fromList addedItems)
 160         in (sort . Map.keys $ expectedCollection) @=?
 161            (sort . Map.keys $ unaryApplyChanges collection commands)
 162
 163 {- | Should validate both that unaryApplyChanges works, and that it is
 164 an identify -}
 165 prop_unaryApplyChangesId :: SyncCollection Int Word8 -> SyncCollection Int Word8 -> Result
 166 prop_unaryApplyChangesId master child =
 167     let (resMaster, resChild) = syncBiDir master child child
 168         newMaster = unaryApplyChanges master resMaster
 169         newChild = unaryApplyChanges child resChild
 170         newMasterKeys = sort . Map.keys $ newMaster
 171         newChildKeys = sort . Map.keys $ newChild
 172         in (True, sort (Map.keys master), sort (Map.keys master)) @=?
 173            (newMasterKeys == newChildKeys, newMasterKeys, newChildKeys)
 174
 175 prop_unaryApplyChanges3 :: SyncCollection Int Word8 -> SyncCollection Int Word8 -> SyncCollection Int Word8 -> Result
 176 prop_unaryApplyChanges3 master child lastChild =
 177     let (resMaster, resChild) = syncBiDir master child lastChild
 178         newMaster = unaryApplyChanges master resMaster
 179         newChild = unaryApplyChanges child resChild
 180     in newMaster @=? newChild
 181
 182 prop_diffCollection :: SyncCollection Int Word8 -> SyncCollection Int Word8 -> Result
 183 prop_diffCollection coll1 coll2 =
 184     let commands = diffCollection coll1 coll2
 185         newcoll2 = unaryApplyChanges coll1 commands
 186         in coll2 @=? newcoll2
 187
 188 q :: Testable a => String -> a -> HU.Test
 189 q = qccheck (defaultConfig {configMaxTest = 250})
 190
 191 allt = [q "Empty" prop_empty,
 192         q "Del all from child" prop_delAllFromChild,
 193         q "Del all from master" prop_delAllFromMaster,
 194         q "Add from master" prop_addFromMaster,
 195         q "All changes to child" prop_allChangesToChild,
 196         q "All changes to master" prop_allChangesToMaster,
 197         q "All changes" prop_allChanges,
 198         q "unaryApplyChanges" prop_unaryApplyChanges,
 199         q "unaryApplyChangesId" prop_unaryApplyChangesId,
 200         q "unaryApplyChanges3" prop_unaryApplyChanges3,
 201         q "diffCollection" prop_diffCollection
 202        ]
 203
 204 testh = HU.runTestTT $ HU.TestList allt
 205 testv = runVerbTestText (HU.putTextToHandle stderr True) $ HU.TestList allt
 206
 207
 208 main =
 209     do testv
 210        return ()
 211