store 0.2.0.0 → 0.2.1.0
raw patch · 8 files changed
+364/−9 lines, 8 filesdep +base64-bytestringdep +directorydep +filepathdep ~th-utilities
Dependencies added: base64-bytestring, directory, filepath
Dependency ranges changed: th-utilities
Files
- ChangeLog.md +12/−0
- src/Data/Store.hs +1/−0
- src/Data/Store/Internal.hs +3/−1
- src/Data/Store/TH/Internal.hs +1/−1
- src/Data/Store/TypeHash/Internal.hs +4/−0
- src/Data/Store/Version.hs +311/−0
- store.cabal +18/−5
- test/Data/StoreSpec.hs +14/−2
ChangeLog.md view
@@ -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:
src/Data/Store.hs view
@@ -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
src/Data/Store/Internal.hs view
@@ -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
src/Data/Store/TH/Internal.hs view
@@ -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
src/Data/Store/TypeHash/Internal.hs view
@@ -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)
+ src/Data/Store/Version.hs view
@@ -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))
store.cabal view
@@ -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
test/Data/StoreSpec.hs view
@@ -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 <https://github.com/feuerbach/smallcheck/pull/34>++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 |]