diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for armor + +## 0.1 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2017, Doug Beardsley +Copyright (c) 2017, Formation 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: + +Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. + +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. + +Neither the name of Doug Beardsley nor the names of its other contributors may +be used to endorse or promote products derived from this software without +specific prior written permission. + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/armor.cabal b/armor.cabal new file mode 100644 --- /dev/null +++ b/armor.cabal @@ -0,0 +1,69 @@ +name: armor +version: 0.1 +synopsis: Armor data structures against serialization backwards compatibility problems +description: Tests the serialization backwards compatibility of data types by storing + serialized representations in .test files to be checked into your project's + version control. +license: BSD3 +license-file: LICENSE +author: Doug Beardsley +maintainer: mightybyte@gmail.com +copyright: Doug Beardsley, Formation Inc. +homepage: https://github.com/mightybyte/armor +bug-reports: https://github.com/mightybyte/armor/issues +category: Data +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 +tested-with: + GHC==7.10.3, + GHC==8.0.2, + GHC==8.2.1, + GHC==8.4.1 + +Source-repository head + Type: git + Location: https://github.com/mightybyte/armor.git + +library + exposed-modules: + Armor + + hs-source-dirs: src + ghc-options: -Wall + build-depends: + HUnit >= 1.5 && < 1.7, + base >= 4.6 && < 4.12, + bytestring >= 0.10 && < 0.11, + containers >= 0.5 && < 0.6, + directory >= 1.2 && < 1.4, + filepath >= 1.4 && < 1.5, + lens >= 4.16 && < 4.17 + + default-language: Haskell2010 + +test-suite testsuite + hs-source-dirs: test + type: exitcode-stdio-1.0 + main-is: Main.hs + + other-modules: + AppA + AppB + TestAppA + TestAppB + + ghc-options: -Wall + build-depends: + HUnit, + aeson >= 1.0 && < 1.3, + armor, + base, + bytestring, + containers, + directory, + hspec >= 2.4 && < 2.5, + lens, + text >= 1.2 && < 1.3 + + default-language: Haskell2010 diff --git a/src/Armor.hs b/src/Armor.hs new file mode 100644 --- /dev/null +++ b/src/Armor.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Armor + ( Version(..) + , Armored(..) + , ArmorConfig(..) + , defArmorConfig + , testArmor + , testArmorMany + ) where + +------------------------------------------------------------------------------ +import Control.Lens +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Map (Map) +import qualified Data.Map as M +import Data.Typeable +#if !MIN_VERSION_base(4,8,0) +import Data.Word +#endif +import System.Directory +import System.FilePath +import Test.HUnit.Base +import Text.Printf +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +-- | Version numbers are simple monotonically increasing positive integers. +newtype Version a = Version { unVersion :: Word } + deriving (Eq,Ord,Show,Read) + + +------------------------------------------------------------------------------ +-- | Core type class for armoring types. Includes a version and all the +-- type's serializations that you want to armor. +class Armored a where + -- | Current version number for the data type. + version :: Version a + -- | Map of serializations keyed by a unique ID used to refer to each + -- serialization. A serialization is a tuple of @(a -> ByteString)@ and + -- @(ByteString -> Maybe a)@. Represented here as a prism. + serializations :: Map String (APrism' ByteString a) + + +------------------------------------------------------------------------------ +-- | The mode of operation for armor test cases. +data ArmorMode + = SaveOnly + -- ^ Write test files for serializations that don't have them, but don't + -- do any tests to verify that existing files are deserialized properly. + | TestOnly + -- ^ Run tests to verify that existing files are deserialized properly, + -- but don't write any missing files. + | SaveAndTest + -- ^ Do both the save and test phases. + deriving (Eq,Ord,Show,Read,Enum,Bounded) + + +------------------------------------------------------------------------------ +-- | Config data for armor tests. +data ArmorConfig = ArmorConfig + { acArmorMode :: ArmorMode + , acStoreDir :: FilePath + -- ^ Directory where all the test serializations are stored. + , acNumVersions :: Maybe Word + -- ^ How many versions back to test for backwards compatibility. A value + -- of @Just 0@ means that it only tests that the current version satisfies + -- @parse . render == id@. @Just 1@ means that it will verify that the + -- previous version can still be parse. @Just 2@ the previous two + -- versions, etc. Nothing means that all versions will be tested. + } + + +------------------------------------------------------------------------------ +-- | Default value for ArmorConfig. +defArmorConfig :: ArmorConfig +defArmorConfig = ArmorConfig SaveAndTest "test-data" Nothing + + +------------------------------------------------------------------------------ +-- | Tests the serialization backwards compatibility of a data type by storing +-- serialized representations in .test files to be checked into your project's +-- version control. +-- +-- First, this function checks the directory 'acStoreDir' for the existence of +-- a file @foo-000.test@. If it doesn't exist, it creates it for each +-- serialization with the serialized representation of the val parameter. +-- +-- Next, it checks that the serialized formats in the most recent +-- 'acNumVersions' of the stored @.test@ files are parsable by the current +-- version of the serialization. +testArmor + :: (Eq a, Show a, Typeable a, Armored a) + => ArmorConfig + -> String + -> a + -> Test +testArmor ac valId val = + TestList [ testIt s | s <- M.toList serializations ] + where + testIt s = test (testSerialization ac valId val s) + + +------------------------------------------------------------------------------ +-- Same as 'testArmor', but more convenient for testing several values of the +-- same type. +testArmorMany + :: (Eq a, Show a, Typeable a, Armored a) + => ArmorConfig + -> Map String a + -> Test +testArmorMany ac valMap = TestList $ map doOne $ M.toList valMap + where + doOne (k,v) = TestLabel k $ testArmor ac k v + + +------------------------------------------------------------------------------ +testSerialization + :: forall a. (Eq a, Show a, Typeable a, Armored a) + => ArmorConfig + -> String + -> a + -> (String, APrism' ByteString a) + -> Assertion +testSerialization ac valId val s@(_,p) = do + let d = getVersionDir ac val s + f = getVersionFilename valId curVer + fp = d f + when (acArmorMode ac /= TestOnly) $ do + createDirectoryIfMissing True d + fileExists <- doesFileExist fp + when (not fileExists) $ + B.writeFile fp (review (clonePrism p) val) + when (acArmorMode ac /= SaveOnly) $ do + mapM_ (assertVersionParses d . Version) vs + where + curVer :: Version a + curVer = version + vs = reverse [maybe 0 (unVersion curVer -) (acNumVersions ac) .. unVersion curVer] + assertVersionParses d ver = do + let f = getVersionFilename valId ver + fp = d f + exists <- doesFileExist fp + if exists + then do bs <- B.readFile fp + case preview (clonePrism p) bs of + Nothing -> assertFailure $ + printf "Not backwards compatible with version %d: %s" + (unVersion ver) fp + Just v -> assertEqual ("File parsed but values didn't match: " ++ fp) val v + else putStrLn $ "\nSkipping missing file " ++ fp + + +------------------------------------------------------------------------------ +getVersionFilename :: String -> Version a -> String +getVersionFilename valId ver = printf "%s-%03d.test" valId (unVersion ver) + + +------------------------------------------------------------------------------ +getVersionDir :: Typeable a => ArmorConfig -> a -> (FilePath, t) -> FilePath +getVersionDir ac val (nm,_) = acStoreDir ac show (typeOf val) nm diff --git a/test/AppA.lhs b/test/AppA.lhs new file mode 100644 --- /dev/null +++ b/test/AppA.lhs @@ -0,0 +1,91 @@ +The easiest way to explain this package is to walk through a case study of using +it. This is a literate Haskell file in the test suite, so let's get some imports +out of the way first. + +> {-# LANGUAGE DeriveGeneric #-} +> +> module AppA where +> +> ------------------------------------------------------------------------------ +> import Armor +> import Control.Lens +> import Data.Aeson +> import Data.ByteString (ByteString) +> import Data.ByteString.Lazy (fromStrict, toStrict) +> import qualified Data.Map as M +> import qualified Data.Text as T +> import Data.Text.Encoding +> import Data.Typeable +> import GHC.Generics +> import Text.Read +> ------------------------------------------------------------------------------ + +Imagine you have the following data types: + +> data Employee = Employee +> { employeeFirstName :: String +> , employeeLastName :: String +> , employeeTenure :: Int +> } deriving (Eq, Ord, Show, Read, Typeable, Generic) +> +> data EmployeeLevel = Executive | Manager | Worker +> deriving (Eq, Ord, Show, Read, Typeable, Generic) + +Ignore this for now. It's just here for testing. + +You want to store this data in your database as a serialized JSON blob. (That +might not very plausible for this example, but it's definitely a fairly common +thing, so suspend disbelief for a moment.) + +> instance FromJSON Employee +> instance ToJSON Employee +> +> instance FromJSON EmployeeLevel +> instance ToJSON EmployeeLevel + +Now, to use the armor package you need to define an `Armored` instance for your +data type. To do that you need to define two things. A version number and a list +of serializations you want armored. We'll discuss the serializations in more +detail below. + +One notable point about the serializations is that we need to be able to create +a unique identifier for them later. So armor requires a `Map String (APrism' +ByteString a)` where the `String` is a unique and hopefully meaningful +identifier for this serialization. + +> instance Armored Employee where +> version = Version 0 +> serializations = M.fromList +> [ ("show", showPrism) +> , ("aeson", aesonPrism) +> ] +> +> instance Armored EmployeeLevel where +> version = Version 0 +> serializations = M.fromList +> [ ("show", showPrism) +> , ("aeson", aesonPrism) +> ] + +This tutorial is a part of the armor test suite, and since we don't want armor +to depend on any specific serialization packages we're using Show as an example +of how armor supports any number of serialiaztions. + +A serialization is simply a pair of a serialization function that converts your +data type to ByteString and a deserialization function that converts a +ByteString to a Maybe of your data type. If you're familiar with the lens +package, this is a prism, so that's what we use here. + +> showPrism :: (Read a, Show a) => Prism' ByteString a +> showPrism = +> prism' (encodeUtf8 . T.pack . show) (readMaybe . T.unpack . decodeUtf8) +> +> aesonPrism :: (FromJSON a, ToJSON a) => Prism' ByteString a +> aesonPrism = +> prism' (toStrict . encode) (decode . fromStrict) +> + +Once you have defined your `Armored` instances, the next step is to define your +tests. To see an example of that go here: + +https://github.com/TaktInc/armor/blob/master/test/TestAppA.lhs diff --git a/test/AppB.lhs b/test/AppB.lhs new file mode 100644 --- /dev/null +++ b/test/AppB.lhs @@ -0,0 +1,60 @@ +> {-# LANGUAGE DeriveGeneric #-} +> +> module AppB where +> +> ------------------------------------------------------------------------------ +> import Armor +> import Data.Aeson +> import qualified Data.Map as M +> import Data.Typeable +> import GHC.Generics +> ------------------------------------------------------------------------------ +> import AppA (showPrism, aesonPrism) +> ------------------------------------------------------------------------------ + +Time goes by and we discover we need to add a new field to Employee. Since we +care about backwards compatibility and there isn't a reasonable default for the +age field, we add it as a Maybe. + +> data Employee = Employee +> { employeeFirstName :: String +> , employeeLastName :: String +> , employeeTenure :: Int +> , employeeAge :: Maybe Int +> } deriving (Eq, Ord, Show, Read, Typeable, Generic) + +The EmployeeLevel data type stays the same. + +> data EmployeeLevel = Executive | Manager | Worker +> deriving (Eq, Ord, Show, Read, Typeable, Generic) +> +> instance FromJSON Employee +> instance ToJSON Employee +> +> instance FromJSON EmployeeLevel +> instance ToJSON EmployeeLevel + +We update the `Armored` instance to version 1. If you forget to updated the +version, the armor tests should still fail because the existing version 0 +serialization files will not be overwritten. + +NOTE / TODO: In the future we may be able to have explicit checking for this +situation and have special alerts to change the version number. + +> instance Armored Employee where +> version = Version 1 +> serializations = M.fromList +> [ ("show", showPrism) +> , ("aeson", aesonPrism) +> ] +> +> instance Armored EmployeeLevel where +> version = Version 0 +> serializations = M.fromList +> [ ("show", showPrism) +> , ("aeson", aesonPrism) +> ] + +Now go to the TestAppB module to see how we update the tests for the new field. + +https://github.com/TaktInc/armor/blob/master/test/TestAppB.lhs diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,31 @@ +module Main where + +------------------------------------------------------------------------------ +import Armor +import Control.Monad +import System.Directory +import Test.HUnit +import Test.Hspec +------------------------------------------------------------------------------ +import TestAppA +import TestAppB +------------------------------------------------------------------------------ + +conf :: ArmorConfig +conf = defArmorConfig + +main :: IO () +main = do + exists <- doesDirectoryExist (acStoreDir conf) + when exists $ removeDirectoryRecursive (acStoreDir conf) + acount <- runTestTT (aTests conf) + bcount <- runTestTT (bTests conf) + putStrLn $ "A: " ++ showCounts acount + putStrLn $ "B: " ++ showCounts bcount + hspec $ describe "armor tests" $ do + it "correctly handles AppA" $ + Counts 8 8 0 0 == acount + it "correctly handles AppB" $ + Counts 10 10 0 1 == bcount + removeDirectoryRecursive (acStoreDir conf) + diff --git a/test/TestAppA.lhs b/test/TestAppA.lhs new file mode 100644 --- /dev/null +++ b/test/TestAppA.lhs @@ -0,0 +1,27 @@ +> module TestAppA where +> +> ------------------------------------------------------------------------------ +> import Test.HUnit +> import qualified Data.Map as M +> ------------------------------------------------------------------------------ +> import Armor +> import AppA +> ------------------------------------------------------------------------------ + +To actually enable the armoring of your data types, write tests as follows: + +> aTests :: ArmorConfig -> Test +> aTests ac = TestList +> [ testArmor ac "e1" (Employee "Bob" "Smith" 5) +> , testArmorMany ac $ M.fromList +> [("e", Executive) , ("m", Manager) , ("w", Worker)] +> ] + +See the documentation for the `testArmor` function for more detailed information. + +With the above tests in your app, you'll see that a number of `.test` files will +be automatically created that store the serialized data and are used to check +that they can be correctly parsed. Eventually you'll need to change the data +type in some way. See this file for a case study of how that might play out: + +https://github.com/TaktInc/armor/blob/master/test/AppB.lhs diff --git a/test/TestAppB.lhs b/test/TestAppB.lhs new file mode 100644 --- /dev/null +++ b/test/TestAppB.lhs @@ -0,0 +1,27 @@ +> module TestAppB where +> +> ------------------------------------------------------------------------------ +> import Test.HUnit +> import qualified Data.Map as M +> ------------------------------------------------------------------------------ +> import Armor +> import AppB +> ------------------------------------------------------------------------------ + +Since the new field is a Maybe, we update the old test with a Nothing value +because that's what we expect the serialization to do. We also add a new test +exercising the new field. This test should have a new value ID so it gets a +different `.test` file. + +> bTests :: ArmorConfig -> Test +> bTests ac = TestList +> [ testArmor ac "e1" (Employee "Bob" "Smith" 5 Nothing) +> , testArmor ac "e2" (Employee "Jane" "Doe" 8 (Just 33)) +> , testArmorMany ac $ M.fromList +> [("e", Executive) , ("m", Manager) , ("w", Worker)] +> ] + +These new tests will pass for the aeson serialization because the generic aeson +deserialization functions will interpret the absence of the age field as a +Nothing. The show serialization will fail because Read for the new data type +requires the age field to be present.