diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,17 @@ # ChangeLog +## 0.2.1.0 + +Release notes: + +* Adds experimental `Data.Store.Version` and deprecates `Data.Store.TypeHash`. + The new functionality is similar to TypeHash, but there are much fewer false + positives of hashes changing. + +Other enhancements: + +* Now exports types related to generics + ## 0.2.0.0 Release notes: diff --git a/src/Data/Store.hs b/src/Data/Store.hs --- a/src/Data/Store.hs +++ b/src/Data/Store.hs @@ -16,6 +16,7 @@ decodeIO, decodeIOWith, decodeIOPortionWith -- * Store class and related types. , Store(..), Size(..), Poke, Peek + , GStoreSize, GStorePoke, GStorePeek -- ** Exceptions thrown by Peek , PeekException(..), peekException ) where diff --git a/src/Data/Store/Internal.hs b/src/Data/Store/Internal.hs --- a/src/Data/Store/Internal.hs +++ b/src/Data/Store/Internal.hs @@ -49,7 +49,9 @@ -- ** Store instances in terms of IArray , sizeArray, pokeArray, peekArray -- ** Store instances in terms of Generic - , genericSize, genericPoke, genericPeek + , GStoreSize, genericSize + , GStorePoke, genericPoke + , GStorePeek, genericPeek -- ** Peek utilities , skip, isolate -- ** Static Size type diff --git a/src/Data/Store/TH/Internal.hs b/src/Data/Store/TH/Internal.hs --- a/src/Data/Store/TH/Internal.hs +++ b/src/Data/Store/TH/Internal.hs @@ -45,7 +45,7 @@ import Prelude import Safe (headMay) import TH.Derive (Deriver(..)) -import TH.ReifyDataType +import TH.ReifySimple import TH.Utilities (expectTyCon1, dequalify, plainInstanceD) instance Deriver (Store a) where diff --git a/src/Data/Store/TypeHash/Internal.hs b/src/Data/Store/TypeHash/Internal.hs --- a/src/Data/Store/TypeHash/Internal.hs +++ b/src/Data/Store/TypeHash/Internal.hs @@ -30,6 +30,10 @@ import Language.Haskell.TH.Syntax (Lift(lift)) import Prelude +{-# DEPRECATED mkManyHasTypeHash, mkHasTypeHash + "Use of Data.Store.TypeHash isn't recommended, as the hashes are too unstable for most uses. Please instead consider using Data.Store.Version. See https://github.com/fpco/store/issues/53" + #-} + newtype Tagged a = Tagged { unTagged :: a } deriving (Eq, Ord, Show, Data, Typeable, Generic) diff --git a/src/Data/Store/Version.hs b/src/Data/Store/Version.hs new file mode 100644 --- /dev/null +++ b/src/Data/Store/Version.hs @@ -0,0 +1,311 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +-- | This module provides utilities which help ensure that we aren't +-- attempting to de-serialize data that is an older or newer version. +-- The 'WithVersion' utility wraps up a datatype along with a version +-- tag. This version tag can either be provided by the user +-- ('namedVersionConfig'), or use a computed hash +-- ('hashedVersionConfig'). +-- +-- The magic here is using an SYB traversal ('Data') to get the +-- structure of all the data-types involved. This info is rendered to +-- text and hashed to yield a hash which describes it. +-- +-- NOTE that this API is still quite new and so is likely to break +-- compatibility in the future. It should also be expected that the +-- computed hashes may change between major version bumps, though this +-- will be minimized when directly feasible. +module Data.Store.Version + ( StoreVersion(..) + , WithVersion(..) + , VersionConfig(..) + , hashedVersionConfig + , namedVersionConfig + , wrapVersion + , checkVersion + , VersionCheckException(..) + ) where + +import Control.Exception +import Control.Monad +import Control.Monad.Trans.State +import qualified Crypto.Hash.SHA1 as SHA1 +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64.URL as B64Url +import qualified Data.ByteString.Char8 as BS8 +import Data.Generics hiding (DataType, Generic) +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Store.Internal +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import qualified Data.Text.IO as T +import Data.Typeable.Internal (TypeRep(..)) +import GHC.Generics (Generic) +import Language.Haskell.TH +import System.Directory +import System.Environment +import System.FilePath +import TH.RelativePaths +import TH.Utilities + +newtype StoreVersion = StoreVersion { unStoreVersion :: BS.ByteString } + deriving (Eq, Show, Ord, Data, Typeable, Generic, Store) + +data WithVersion a = WithVersion a StoreVersion + deriving (Eq, Show, Ord, Data, Typeable, Generic) + +instance Store a => Store (WithVersion a) + +-- | Configuration for the version checking of a particular type. +data VersionConfig a = VersionConfig + { vcExpectedHash :: Maybe String + -- ^ When set, specifies the hash which is expected to be computed. + , vcManualName :: Maybe String + -- ^ When set, specifies the name to instead use to tag the data. + , vcIgnore :: S.Set String + -- ^ DataTypes to ignore. + , vcRenames :: M.Map String String + -- ^ Allowed renamings of datatypes, useful when they move. + } deriving (Eq, Show, Data, Typeable, Generic) + +hashedVersionConfig :: String -> VersionConfig a +hashedVersionConfig hash = VersionConfig + { vcExpectedHash = Just hash + , vcManualName = Nothing + , vcIgnore = S.empty + , vcRenames = M.empty + } + +namedVersionConfig :: String -> String -> VersionConfig a +namedVersionConfig name hash = VersionConfig + { vcExpectedHash = Just hash + , vcManualName = Just name + , vcIgnore = S.empty + , vcRenames = M.empty + } + +wrapVersion :: Data a => VersionConfig a -> Q Exp +wrapVersion = impl Wrap + +checkVersion :: Data a => VersionConfig a -> Q Exp +checkVersion = impl Check + +data WhichFunc = Wrap | Check + +impl :: forall a. Data a => WhichFunc -> VersionConfig a -> Q Exp +impl wf vc = do + let proxy = Proxy :: Proxy a + info = encodeUtf8 (T.pack (getStructureInfo (vcIgnore vc) (vcRenames vc) proxy)) + hash = SHA1.hash info + hashb64 = BS8.unpack (B64Url.encode hash) + version = case vcManualName vc of + Nothing -> [e| StoreVersion hash |] + Just name -> [e| StoreVersion name |] + case vcExpectedHash vc of + Nothing -> return () + Just expectedHash -> do + let shownType = showsQualTypeRep (vcRenames vc) 0 (typeRep proxy) "" + -- FIXME: sanitize expected and handle null + path <- storeVersionedPath expectedHash + if hashb64 == expectedHash + then writeVersionInfo path shownType info + else do + newPath <- storeVersionedPath hashb64 + writeVersionInfo newPath shownType info + exists <- runIO $ doesFileExist path + extraMsg <- if not exists + then return ", but no file found with previously stored structural info." + else return (", use something like the following to compare with the old structural info:\n\n" ++ + "diff -u " ++ show path ++ " " ++ show newPath) + error $ + "For " ++ shownType ++ ",\n" ++ + "Data.Store.Version expected hash " ++ show hashb64 ++ + ", but " ++ show expectedHash ++ " is specified.\n" ++ + "The data used to construct the hash has been written to " ++ show newPath ++ + extraMsg ++ "\n" + case wf of + Wrap -> [e| (\x -> (x :: $(typeRepToType (typeRep proxy))) `WithVersion` $(version)) |] + Check -> [e| (\(WithVersion x gotVersion) -> + if gotVersion /= $(version) + then Left (VersionCheckException + { expectedVersion = $(version) + , receivedVersion = gotVersion + }) + else Right x) |] + +{- + txtWithComments <- runIO $ T.readFile path + let txt = T.unlines $ dropWhile ("--" `T.isPrefixOf`) $ T.lines txtWithComments + storedHash = BS8.unpack (B64Url.encode (SHA1.hash (encodeUtf8 txt))) + if storedHash == expectedHash + then return (", compare with the structural info that matches the hash, found in " ++ show path) + else return (", but the old file found also doesn't match the hash.") +-} + +writeVersionInfo :: FilePath -> String -> BS.ByteString -> Q () +writeVersionInfo path shownType info = runIO $ do + createDirectoryIfMissing True (takeDirectory path) + T.writeFile path $ T.unlines $ + [ T.pack ("-- Structural info for type " ++ shownType) + , "-- Generated by an invocation of functions in Data.Store.Version" + ] ++ T.lines (decodeUtf8 info) + +storeVersionedPath :: String -> Q FilePath +storeVersionedPath filename = do + mstack <- runIO (lookupEnv "STACK_EXE") + let dirName = case mstack of + Just _ -> ".stack-work" + Nothing -> "dist" + pathRelativeToCabalPackage (dirName "store-versioned" filename) + +-- Implementation details + +data S = S + { sResults :: M.Map String String + , sCurResult :: String + , sFieldNames :: [String] + } + +getStructureInfo :: forall a. Data a => S.Set String -> M.Map String String -> Proxy a -> String +getStructureInfo ignore renames = renderResults . sResults . flip execState (S M.empty "" []) . getStructureInfo' ignore renames + where + renderResults = unlines . map (\(k, v) -> k ++ v) . M.toAscList + +getStructureInfo' :: forall a. Data a => S.Set String -> M.Map String String -> Proxy a -> State S () +getStructureInfo' ignore renames _ = do + s0 <- get + when (M.notMember label (sResults s0)) $ + if S.member shownType ignore + then setResult " ignored\n" + else case dataTypeRep (dataTypeOf (undefined :: a)) of + AlgRep cs -> do + setResult "" + mapM_ goConstr (zip (True : repeat False) cs) + result <- gets sCurResult + setResult (if null cs then result ++ "\n" else result) + IntRep -> setResult " has IntRep\n" + FloatRep -> setResult " has FloatRep\n" + CharRep -> setResult " has CharRep\n" + NoRep + | S.member shownType ignore -> setResult " has NoRep\n" + | otherwise -> error $ + "\nNoRep in Data.Store.Version for " ++ show shownType ++ + ".\nIn the future it will be possible to statically " ++ + "declare a global serialization version for this type. " ++ + "\nUntil then you will need to use 'vcIgnore', and " ++ + "understand that serialization changes for affected types " ++ + "will not be detected.\n" + where + setResult x = + modify (\s -> S + { sResults = M.insert label x (sResults s) + , sCurResult = "" + , sFieldNames = [] + }) + label = "data-type " ++ shownType + shownType = showsQualTypeRep renames 0 (typeRep (Proxy :: Proxy a)) "" + goConstr :: (Bool, Constr) -> State S () + goConstr (isFirst, c) = do + modify (\s -> s + { sFieldNames = constrFields c ++ map (\ix -> "slot " ++ show (ix :: Int)) [0..] + , sCurResult = sCurResult s ++ (if isFirst then "\n = " else " | ") ++ showConstr c ++ " {\n" + }) + void (fromConstrM goField c :: State S a) + modify (\s -> s { sCurResult = sCurResult s ++ " }\n" }) + goField :: forall b. Data b => State S b + goField = do + s <- get + case sFieldNames s of + [] -> fail "impossible case in getStructureInfo'" + (name:names) -> do + getStructureInfo' ignore renames (Proxy :: Proxy b) + s' <- get + put s + { sResults = sResults s' + , sCurResult = sCurResult s ++ " " ++ name ++ " :: " ++ showsQualTypeRep renames 0 (typeRep (Proxy :: Proxy b)) "\n" + , sFieldNames = names + } + return (error "unexpected evaluation") + +showsQualTypeRep :: M.Map String String -> Int -> TypeRep -> ShowS +#if MIN_VERSION_base(4,8,0) +showsQualTypeRep renames p (TypeRep _ tycon _ tys) = +#else +showsQualTypeRep renames p (TypeRep _ tycon tys) = +#endif + case tys of + [] -> showsQualTyCon renames tycon + [x] | tycon == tcList -> showChar '[' . showsQualTypeRep renames 0 x . showChar ']' + where + [a,r] | tycon == tcFun -> showParen (p > 8) $ + showsQualTypeRep renames 9 a . + showString " -> " . + showsQualTypeRep renames 8 r + xs | isTupleTyCon tycon -> showTuple renames xs + | otherwise -> + showParen (p > 9) $ + showsQualTyCon renames tycon . + showChar ' ' . + showArgs renames (showChar ' ') tys + +showsQualTyCon :: M.Map String String -> TyCon -> ShowS +showsQualTyCon renames tc = showString (M.findWithDefault name name renames) + where + name = tyConModule tc ++ "." ++ tyConName tc + +isTupleTyCon :: TyCon -> Bool +isTupleTyCon tc + | ('(':',':_) <- tyConName tc = True + | otherwise = False + +showArgs :: M.Map String String -> ShowS -> [TypeRep] -> ShowS +showArgs _ _ [] = id +showArgs renames _ [a] = showsQualTypeRep renames 10 a +showArgs renames sep (a:as) = showsQualTypeRep renames 10 a . sep . showArgs renames sep as + +showTuple :: M.Map String String -> [TypeRep] -> ShowS +showTuple renames args + = showChar '(' + . showArgs renames (showChar ',') args + . showChar ')' + +tcList :: TyCon +tcList = tyConOf (Proxy :: Proxy [()]) + +tcFun :: TyCon +tcFun = tyConOf (Proxy :: Proxy (Int -> Int)) + +tyConOf :: Typeable a => Proxy a -> TyCon +tyConOf = typeRepTyCon . typeRep + +data VersionCheckException = VersionCheckException + { expectedVersion :: StoreVersion + , receivedVersion :: StoreVersion + } deriving +#if MIN_VERSION_base(4,8,0) + (Typeable, Show) + +instance Exception VersionCheckException where + displayException = displayVCE +#else + (Typeable) + +instance Show VersionCheckException where + show = displayVCE + +instance Exception VersionCheckException +#endif + +displayVCE :: VersionCheckException -> String +displayVCE VersionCheckException{..} = + "Mismatch detected by Data.Store.Version - expected " ++ + T.unpack (decodeUtf8With lenientDecode (unStoreVersion expectedVersion)) ++ " but got " ++ + T.unpack (decodeUtf8With lenientDecode (unStoreVersion receivedVersion)) diff --git a/store.cabal b/store.cabal --- a/store.cabal +++ b/store.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: store -version: 0.2.0.0 +version: 0.2.1.0 synopsis: Fast binary serialization homepage: https://github.com/fpco/store#readme bug-reports: https://github.com/fpco/store/issues @@ -42,23 +42,27 @@ Data.Store.TH.Internal Data.Store.TypeHash Data.Store.TypeHash.Internal + Data.Store.Version System.IO.ByteBuffer other-modules: Data.Store.Impl build-depends: base >=4.7 && <5 , store-core >=0.2 && <0.3 - , th-utilities >=0.1.1.0 + , th-utilities >=0.2 , primitive >=0.6 , th-reify-many >=0.1.6 , array >=0.5.0.0 , base-orphans >=0.4.3 + , base64-bytestring >= 0.1.1 , bytestring >=0.10.4.0 , conduit >=1.2.3.1 , containers >=0.5.5.1 , cryptohash >=0.11.6 , deepseq >=1.3.0.2 + , directory >= 1.2 , fail >=4.9.0.0 + , filepath >= 1.3 , ghc-prim >=0.3.1.0 , hashable >=1.2.3.1 , hspec >=2.1.2 @@ -96,17 +100,20 @@ build-depends: base >=4.7 && <5 , store-core >=0.2 && <0.3 - , th-utilities >=0.1.1.0 + , th-utilities >=0.2 , primitive >=0.6 , th-reify-many >=0.1.6 , array >=0.5.0.0 , base-orphans >=0.4.3 + , base64-bytestring >= 0.1.1 , bytestring >=0.10.4.0 , conduit >=1.2.3.1 , containers >=0.5.5.1 , cryptohash >=0.11.6 , deepseq >=1.3.0.2 + , directory >= 1.2 , fail >=4.9.0.0 + , filepath >= 1.3 , ghc-prim >=0.3.1.0 , hashable >=1.2.3.1 , hspec >=2.1.2 @@ -147,17 +154,20 @@ build-depends: base >=4.7 && <5 , store-core >=0.2 && <0.3 - , th-utilities >=0.1.1.0 + , th-utilities >=0.2 , primitive >=0.6 , th-reify-many >=0.1.6 , array >=0.5.0.0 , base-orphans >=0.4.3 + , base64-bytestring >= 0.1.1 , bytestring >=0.10.4.0 , conduit >=1.2.3.1 , containers >=0.5.5.1 , cryptohash >=0.11.6 , deepseq >=1.3.0.2 + , directory >= 1.2 , fail >=4.9.0.0 + , filepath >= 1.3 , ghc-prim >=0.3.1.0 , hashable >=1.2.3.1 , hspec >=2.1.2 @@ -204,17 +214,20 @@ build-depends: base >=4.7 && <5 , store-core >=0.2 && <0.3 - , th-utilities >=0.1.1.0 + , th-utilities >=0.2 , primitive >=0.6 , th-reify-many >=0.1.6 , array >=0.5.0.0 , base-orphans >=0.4.3 + , base64-bytestring >= 0.1.1 , bytestring >=0.10.4.0 , conduit >=1.2.3.1 , containers >=0.5.5.1 , cryptohash >=0.11.6 , deepseq >=1.3.0.2 + , directory >= 1.2 , fail >=4.9.0.0 + , filepath >= 1.3 , ghc-prim >=0.3.1.0 , hashable >=1.2.3.1 , hspec >=2.1.2 diff --git a/test/Data/StoreSpec.hs b/test/Data/StoreSpec.hs --- a/test/Data/StoreSpec.hs +++ b/test/Data/StoreSpec.hs @@ -9,6 +9,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.StoreSpec where import Control.Applicative @@ -31,6 +32,7 @@ import Data.Monoid import Data.Primitive.Types (Addr) import Data.Proxy (Proxy(..)) +import Data.Ratio (numerator, denominator) import Data.Sequence (Seq) import Data.Sequences (fromList) import Data.Set (Set) @@ -211,6 +213,16 @@ deriving instance Show NameSpace #endif +-- We define our own Serial instance for 'Ratio' because of + +newtype SerialRatio a = SerialRatio (Ratio a) + deriving (Store, Eq, Show) + +instance (Integral i, Serial m i) => Serial m (SerialRatio i) where + series = pairToRatio <$> series + where + pairToRatio (n, Positive d) = SerialRatio (n :% d) + ------------------------------------------------------------------------ -- Test datatypes for generics support @@ -287,7 +299,7 @@ $(smallcheckManyStore verbose 2 [ [t| SV.Vector Int8 |] , [t| V.Vector Int8 |] - , [t| Ratio Int8 |] + , [t| SerialRatio Int8 |] , [t| Complex Int8 |] , [t| Dual Int8 |] , [t| Sum Int8 |] @@ -298,7 +310,7 @@ , [t| Either Int8 Int8 |] , [t| SV.Vector Int64 |] , [t| V.Vector Int64 |] - , [t| Ratio Int64 |] + , [t| SerialRatio Int64 |] , [t| Complex Int64 |] , [t| Dual Int64 |] , [t| Sum Int64 |]