{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} #ifdef DEFAULT_SIGNATURES {-# LANGUAGE DefaultSignatures #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.SafeCopy.SafeCopy -- Copyright : PublicDomain -- -- Maintainer : lemmih@gmail.com -- Portability : non-portable (uses GHC extensions) -- -- SafeCopy extends the parsing and serialization capabilities of Data.Binary -- to include nested version control. Nested version control means that you -- can change the defintion and binary format of a type nested deep within -- other types without problems. -- module Data.SafeCopy.SafeCopy where import Data.Serialize import Control.Monad import Data.Int (Int32) import Data.List -- | The central mechanism for dealing with version control. -- -- This type class specifies what data migrations can happen -- and how they happen. class SafeCopy (MigrateFrom a) => Migrate a where -- | This is the type we're extending. Each type capable of migration can -- only extend one other type. type MigrateFrom a -- | This method specifies how to migrate from the older type to the newer -- one. It will never be necessary to use this function manually as it -- all taken care of internally in the library. migrate :: MigrateFrom a -> a -- | This is a wrapper type used migrating backwards in the chain of compatible types. newtype Reverse a = Reverse { unReverse :: a } -- | The kind of a data type determines how it is tagged (if at all). -- -- Primitives kinds (see 'primitive') are not tagged with a version -- id and hence cannot be extended later. -- -- Extensions (see 'extension') tells the system that there exists -- a previous version of the data type which should be migrated if -- needed. -- -- There is also a default kind which is neither primitive nor is -- an extension of a previous type. data Kind a where Primitive :: Kind a Base :: Kind a Extends :: (Migrate a) => Proxy (MigrateFrom a) -> Kind a Extended :: (Migrate (Reverse a)) => Kind a -> Kind a isPrimitive :: Kind a -> Bool isPrimitive Primitive = True isPrimitive _ = False -- | Wrapper for data that was saved without a version tag. newtype Prim a = Prim { getPrimitive :: a } -- | The centerpiece of this library. Defines a version for a data type -- together with how it should be serialized/parsed. -- -- Users should define instances of 'SafeCopy' for their types -- even though 'getCopy' and 'putCopy' can't be used directly. -- To serialize/parse a data type using 'SafeCopy', see 'safeGet' -- and 'safePut'. class SafeCopy a where -- | The version of the type. -- -- Only used as a key so it must be unique (this is checked at run-time) -- but doesn't have to be sequential or continuous. -- -- The default version is '0'. version :: Version a version = Version 0 -- | The kind specifies how versions are dealt with. By default, -- values are tagged with their version id and don't have any -- previous versions. See 'extension' and the much less used -- 'primitive'. kind :: Kind a kind = Base -- | This method defines how a value should be parsed without also worrying -- about writing out the version tag. This function cannot be used directly. -- One should use 'safeGet', instead. getCopy :: Contained (Get a) -- | This method defines how a value should be parsed without worrying about -- previous versions or migrations. This function cannot be used directly. -- One should use 'safeGet', instead. putCopy :: a -> Contained Put -- | Internal function that should not be overrided. -- @Consistent@ iff the version history is consistent -- (i.e. there are no duplicate version numbers) and -- the chain of migrations is valid. -- -- This function is in the typeclass so that this -- information is calculated only once during the program -- lifetime, instead of everytime 'safeGet' or 'safePut' is -- used. internalConsistency :: Consistency a internalConsistency = computeConsistency Proxy -- | Version profile. objectProfile :: Profile a objectProfile = mkProfile Proxy -- | The name of the type. This is only used in error -- message strings. -- Feel free to leave undefined in your instances. errorTypeName :: Proxy a -> String errorTypeName _ = "<unkown type>" #ifdef DEFAULT_SIGNATURES default getCopy :: Serialize a => Contained (Get a) getCopy = contain get default putCopy :: Serialize a => a -> Contained Put putCopy = contain . put #endif -- constructGetterFromVersion :: SafeCopy a => Version a -> Kind (MigrateFrom (Reverse a)) -> Get (Get a) constructGetterFromVersion :: SafeCopy a => Version a -> Kind a -> Either String (Get a) constructGetterFromVersion diskVersion orig_kind = worker False diskVersion orig_kind where worker :: forall a. SafeCopy a => Bool -> Version a -> Kind a -> Either String (Get a) worker fwd thisVersion thisKind | version == thisVersion = return $ unsafeUnPack getCopy | otherwise = case thisKind of Primitive -> Left $ errorMsg thisKind "Cannot migrate from primitive types." Base -> Left $ errorMsg thisKind versionNotFound Extends b_proxy -> do previousGetter <- worker fwd (castVersion diskVersion) (kindFromProxy b_proxy) return $ fmap migrate previousGetter Extended{} | fwd -> Left $ errorMsg thisKind versionNotFound Extended a_kind -> do let rev_proxy :: Proxy (MigrateFrom (Reverse a)) rev_proxy = Proxy forwardGetter :: Either String (Get a) forwardGetter = fmap (fmap (unReverse . migrate)) $ worker True (castVersion thisVersion) (kindFromProxy rev_proxy) previousGetter :: Either String (Get a) previousGetter = worker fwd (castVersion thisVersion) a_kind case forwardGetter of Left{} -> previousGetter Right val -> Right val versionNotFound = "Cannot find getter associated with this version number: " ++ show diskVersion errorMsg fail_kind msg = concat [ "safecopy: " , errorTypeName (proxyFromKind fail_kind) , ": " , msg ] ------------------------------------------------- -- The public interface. These functions are used -- to parse/serialize and to create new parsers & -- serialisers. -- | Parse a version tagged data type and then migrate it to the desired type. -- Any serialized value has been extended by the return type can be parsed. safeGet :: SafeCopy a => Get a safeGet = join getSafeGet -- | Parse a version tag and return the corresponding migrated parser. This is -- useful when you can prove that multiple values have the same version. -- See 'getSafePut'. getSafeGet :: forall a. SafeCopy a => Get (Get a) getSafeGet = checkConsistency proxy $ case kindFromProxy proxy of Primitive -> return $ unsafeUnPack getCopy a_kind -> do v <- get case constructGetterFromVersion v a_kind of Right getter -> return getter Left msg -> fail msg where proxy = Proxy :: Proxy a -- | Serialize a data type by first writing out its version tag. This is much -- simpler than the corresponding 'safeGet' since previous versions don't -- come into play. safePut :: SafeCopy a => a -> Put safePut a = do putter <- getSafePut putter a -- | Serialize the version tag and return the associated putter. This is useful -- when serializing multiple values with the same version. See 'getSafeGet'. getSafePut :: forall a. SafeCopy a => PutM (a -> Put) getSafePut = checkConsistency proxy $ case kindFromProxy proxy of Primitive -> return $ \a -> unsafeUnPack (putCopy $ asProxyType a proxy) _ -> do put (versionFromProxy proxy) return $ \a -> unsafeUnPack (putCopy $ asProxyType a proxy) where proxy = Proxy :: Proxy a -- | The extended_base kind lets the system know that there is -- at least one future version of this type. extended_extension :: (SafeCopy a, Migrate a, Migrate (Reverse a)) => Kind a extended_extension = Extended extension -- | The extended_base kind lets the system know that there is -- at least one future version of this type. extended_base :: (Migrate (Reverse a)) => Kind a extended_base = Extended base -- | The extension kind lets the system know that there is -- at least one previous version of this type. A given data type -- can only extend a single other data type. However, it is -- perfectly fine to build chains of extensions. The migrations -- between each step is handled automatically. extension :: (SafeCopy a, Migrate a) => Kind a extension = Extends Proxy -- | The default kind. Does not extend any type. base :: Kind a base = Base -- | Primitive kinds aren't version tagged. This kind is used for small or built-in -- types that won't change such as 'Int' or 'Bool'. primitive :: Kind a primitive = Primitive ------------------------------------------------- -- Data type versions. Essentially just a unique -- identifier used to lookup the corresponding -- parser function. -- | A simple numeric version id. newtype Version a = Version {unVersion :: Int32} deriving (Read,Show,Eq) castVersion :: Version a -> Version b castVersion (Version a) = Version a instance Num (Version a) where Version a + Version b = Version (a+b) Version a - Version b = Version (a-b) Version a * Version b = Version (a*b) negate (Version a) = Version (negate a) abs (Version a) = Version (abs a) signum (Version a) = Version (signum a) fromInteger i = Version (fromInteger i) instance Serialize (Version a) where get = liftM Version get put = put . unVersion ------------------------------------------------- -- Container type to control the access to the -- parsers/putters. -- | To ensure that no-one reads or writes values without handling versions -- correct, it is necessary to restrict access to 'getCopy' and 'putCopy'. -- This is where 'Contained' enters the picture. It allows you to put -- values in to a container but not to take them out again. newtype Contained a = Contained {unsafeUnPack :: a} -- | Place a value in an unbreakable container. contain :: a -> Contained a contain = Contained ------------------------------------------------- -- Consistency checking data Profile a = PrimitiveProfile | InvalidProfile String | Profile { profileCurrentVersion :: Int32 , profileSupportedVersions :: [Int32] } deriving (Show) mkProfile :: SafeCopy a => Proxy a -> Profile a mkProfile a_proxy = case computeConsistency a_proxy of NotConsistent msg -> InvalidProfile msg Consistent | isPrimitive (kindFromProxy a_proxy) -> PrimitiveProfile Consistent -> Profile{ profileCurrentVersion = unVersion (versionFromProxy a_proxy) , profileSupportedVersions = availableVersions a_proxy } data Consistency a = Consistent | NotConsistent String availableVersions :: SafeCopy a => Proxy a -> [Int32] availableVersions a_proxy = worker True (kindFromProxy a_proxy) where worker :: SafeCopy b => Bool -> Kind b -> [Int32] worker fwd b_kind = case b_kind of Primitive -> [] Base -> [unVersion (versionFromKind b_kind)] Extends b_proxy -> unVersion (versionFromKind b_kind) : worker False (kindFromProxy b_proxy) Extended sub_kind | fwd -> worker False (getForwardKind sub_kind) Extended sub_kind -> worker False sub_kind getForwardKind :: (Migrate (Reverse a)) => Kind a -> Kind (MigrateFrom (Reverse a)) getForwardKind _ = kind -- Extend chains must end in a Base kind. Ending in a Primitive is an error. validChain :: SafeCopy a => Proxy a -> Bool validChain a_proxy = worker (kindFromProxy a_proxy) where worker Primitive = True worker Base = True worker (Extends b_proxy) = check (kindFromProxy b_proxy) worker (Extended a_kind) = worker a_kind check :: SafeCopy b => Kind b -> Bool check b_kind = case b_kind of Primitive -> False Base -> True Extends c_proxy -> check (kindFromProxy c_proxy) Extended sub_kind -> check sub_kind -- Verify that the SafeCopy instance is consistent. checkConsistency :: (SafeCopy a, Monad m) => Proxy a -> m b -> m b checkConsistency proxy ks = case consistentFromProxy proxy of NotConsistent msg -> fail msg Consistent -> ks {-# INLINE computeConsistency #-} computeConsistency :: SafeCopy a => Proxy a -> Consistency a computeConsistency proxy -- Match a few common cases before falling through to the general case. -- This allows use to generate nearly all consistencies at compile-time. | isObviouslyConsistent (kindFromProxy proxy) = Consistent | versions /= nub versions = NotConsistent $ "Duplicate version tags: " ++ show versions | not (validChain proxy) = NotConsistent "Primitive types cannot be extended as they have no version tag." | otherwise = Consistent where versions = availableVersions proxy isObviouslyConsistent :: Kind a -> Bool isObviouslyConsistent Primitive = True isObviouslyConsistent Base = True isObviouslyConsistent _ = False ------------------------------------------------- -- Small utility functions that mean we don't -- have to depend on ScopedTypeVariables. proxyFromConsistency :: Consistency a -> Proxy a proxyFromConsistency _ = Proxy proxyFromKind :: Kind a -> Proxy a proxyFromKind _ = Proxy consistentFromProxy :: SafeCopy a => Proxy a -> Consistency a consistentFromProxy _ = internalConsistency versionFromProxy :: SafeCopy a => Proxy a -> Version a versionFromProxy _ = version versionFromKind :: (SafeCopy a) => Kind a -> Version a versionFromKind _ = version versionFromReverseKind :: (SafeCopy a, SafeCopy (MigrateFrom (Reverse a))) => Kind a -> Version (MigrateFrom (Reverse a)) versionFromReverseKind _ = version kindFromProxy :: SafeCopy a => Proxy a -> Kind a kindFromProxy _ = kind ------------------------------------------------- -- Type proxies data Proxy a = Proxy mkProxy :: a -> Proxy a mkProxy _ = Proxy asProxyType :: a -> Proxy a -> a asProxyType a _ = a