store-0.7.18/bench/0000755000000000000000000000000014233045224012207 5ustar0000000000000000store-0.7.18/src/0000755000000000000000000000000014233045224011717 5ustar0000000000000000store-0.7.18/src/Data/0000755000000000000000000000000014233045224012570 5ustar0000000000000000store-0.7.18/src/Data/Store/0000755000000000000000000000000014507702646013700 5ustar0000000000000000store-0.7.18/src/Data/Store/TH/0000755000000000000000000000000014272422325014203 5ustar0000000000000000store-0.7.18/src/Data/Store/TypeHash/0000755000000000000000000000000014442511610015410 5ustar0000000000000000store-0.7.18/src/System/0000755000000000000000000000000014233045224013203 5ustar0000000000000000store-0.7.18/src/System/IO/0000755000000000000000000000000014442512103013507 5ustar0000000000000000store-0.7.18/test/0000755000000000000000000000000014233045224012107 5ustar0000000000000000store-0.7.18/test/Data/0000755000000000000000000000000014507702646012774 5ustar0000000000000000store-0.7.18/test/Data/Store/0000755000000000000000000000000014233045224014054 5ustar0000000000000000store-0.7.18/test/Data/StoreSpec/0000755000000000000000000000000014233045224014667 5ustar0000000000000000store-0.7.18/test/System/0000755000000000000000000000000014233045224013373 5ustar0000000000000000store-0.7.18/test/System/IO/0000755000000000000000000000000014233045224013702 5ustar0000000000000000store-0.7.18/src/Data/Store.hs0000644000000000000000000000343014233045224014220 0ustar0000000000000000-- | This is the main public API of the store package. The functions -- exported here are more likely to be stable between versions. -- -- Usually you won't need to write your own 'Store' instances, and -- instead can rely on either using the 'Generic' deriving approach or -- "Data.Store.TH" for defining 'Store' instances for your datatypes. -- There are some tradeoffs here - the generics instances do not require -- @-XTemplateHaskell@, but they do not optimize as well for sum types -- that only require a constant number of bytes. -- -- If you need streaming encode / decode of multiple store encoded -- messages, take a look at the @store-streaming@ package. -- -- = Gotchas -- -- Store is best used for communication between trusted processes and -- local caches. It can certainly be used for other purposes, but the -- builtin set of instances have some gotchas to be aware of: -- -- * Store's builtin instances serialize in a format which depends on -- machine endianness. -- -- * Store's builtin instances trust the data when deserializing. For -- example, the deserialization of `Vector` will read the vector's -- link from the first 8 bytes. It will then allocate enough memory -- to store all the elements. Malicious or malformed input could -- cause allocation of large amounts of memory. See -- https://github.com/fpco/store/issues/122 module Data.Store ( -- * Encoding and decoding strict ByteStrings. encode, decode, decodeWith, decodeEx, decodeExWith, decodeExPortionWith, decodeIO, decodeIOWith, decodeIOPortionWith -- * Store class and related types. , Store(..), Size(..), Poke, Peek , GStoreSize, GStorePoke, GStorePeek -- ** Exceptions thrown by Peek , PeekException(..), peekException ) where import Data.Store.Internal store-0.7.18/src/Data/Store/Internal.hs0000644000000000000000000007521414233045367016015 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes#-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE EmptyCase #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Internal API for the store package. The functions here which are -- not re-exported by "Data.Store" are less likely to have stable APIs. -- -- This module also defines most of the included 'Store' instances, for -- types from the base package and other commonly used packages -- (bytestring, containers, text, time, etc). module Data.Store.Internal ( -- * Encoding and decoding strict ByteStrings. encode, decode, decodeWith, decodeEx, decodeExWith, decodeExPortionWith , decodeIO, decodeIOWith, decodeIOPortionWith -- * Store class and related types. , Store(..), Poke, Peek, runPeek -- ** Exceptions thrown by Poke , PokeException(..), pokeException -- ** Exceptions thrown by Peek , PeekException(..), peekException, tooManyBytes -- ** Size type , Size(..) , getSize, getSizeWith , combineSize, combineSizeWith, addSize -- ** Store instances in terms of IsSequence , sizeSequence, pokeSequence, peekSequence -- ** Store instances in terms of IsSet , sizeSet, pokeSet, peekSet -- ** Store instances in terms of IsMap , sizeMap, pokeMap, peekMap -- *** Utilities for ordered maps , sizeOrdMap, pokeOrdMap, peekOrdMapWith -- ** Store instances in terms of IArray , sizeArray, pokeArray, peekArray -- ** Store instances in terms of Generic , GStoreSize, genericSize , GStorePoke, genericPoke , GStorePeek, genericPeek -- ** Peek utilities , skip, isolate , peekMagic -- ** Static Size type -- -- This portion of the library is still work-in-progress. -- 'IsStaticSize' is only supported for strict ByteStrings, in order -- to support the use case of 'Tagged'. , IsStaticSize(..), StaticSize(..), toStaticSizeEx, liftStaticSize, staticByteStringExp ) where import Control.Applicative import Control.DeepSeq (NFData) import Control.Exception (throwIO) import Control.Monad (when) import Control.Monad.IO.Class (liftIO) import qualified Data.Array.Unboxed as A import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Short.Internal as SBS import Data.Containers (IsMap, ContainerKey, MapValue, mapFromList, mapToList, IsSet, setFromList) import Data.Complex (Complex (..)) import Data.Data (Data) import Data.Fixed (Fixed (..), Pico) import Data.Foldable (forM_, foldl') import Data.Functor.Contravariant import Data.Functor.Identity (Identity (..)) import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) import Data.Hashable (Hashable) import Data.Int import Data.IntMap (IntMap) import qualified Data.IntMap.Strict as IntMap import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import qualified Data.List.NonEmpty as NE import Data.Map (Map) import qualified Data.Map.Strict as Map import Data.MonoTraversable import Data.Monoid import Data.Orphans () import Data.Primitive.ByteArray import Data.Proxy (Proxy(..)) import Data.Sequence (Seq) import Data.Sequences (IsSequence, Index, replicateM) import Data.Set (Set) import qualified Data.Set as Set import Data.Store.Impl import Data.Store.Core import Data.Store.TH.Internal import qualified Data.Text as T import qualified Data.Text.Array as TA import qualified Data.Text.Foreign as T import qualified Data.Text.Internal as T import qualified Data.Time as Time import qualified Data.Time.Clock.TAI as Time import Data.Typeable (Typeable) import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV import qualified Data.Vector.Storable as SV import qualified Data.Vector.Storable.Mutable as MSV import Data.Void import Data.Word import Foreign.C.Types () import Foreign.Ptr (plusPtr, minusPtr) import Foreign.Storable (Storable, sizeOf) import GHC.Generics (Generic) import GHC.Real (Ratio(..)) import GHC.TypeLits import Instances.TH.Lift () import Language.Haskell.TH import Language.Haskell.TH.Instances () import Language.Haskell.TH.ReifyMany import Language.Haskell.TH.Syntax import Network.Socket (AddrInfo) import Numeric.Natural (Natural) import Prelude import TH.Derive #if MIN_VERSION_time(1,8,0) import qualified Data.Time.Clock.System as Time #endif #if MIN_VERSION_time(1,9,0) import qualified Data.Time.Format.ISO8601 as Time #endif #if MIN_VERSION_time(1,11,0) import qualified Data.Time.Calendar.Quarter as Time import qualified Data.Time.Calendar.WeekDate as Time #endif #ifdef INTEGER_GMP import qualified GHC.Integer.GMP.Internals as I import GHC.Types (Int (I#)) #else import GHC.Types (Word (W#)) import qualified GHC.Integer.Simple.Internals as I #endif -- Conditional import to avoid warning #ifdef INTEGER_GMP #if MIN_VERSION_integer_gmp(1,0,0) import GHC.Prim (sizeofByteArray#) #endif #endif -- TODO: higher arities? Limited now by Generics instances for tuples $(return $ map deriveTupleStoreInstance [2..7]) $(deriveManyStoreFromStorable (\ty -> case ty of ConT n | elem n [''Char, ''Int, ''Int64, ''Word, ''Word8, ''Word32] -> True _ -> False )) ------------------------------------------------------------------------ -- Utilities for defining list-like 'Store' instances in terms of 'IsSequence' -- | Implement 'size' for an 'IsSequence' of 'Store' instances. -- -- Note that many monomorphic containers have more efficient -- implementations (for example, via memcpy). sizeSequence :: forall t. (IsSequence t, Store (Element t)) => Size t sizeSequence = VarSize $ \t -> case size :: Size (Element t) of ConstSize n -> n * (olength t) + sizeOf (undefined :: Int) VarSize f -> ofoldl' (\acc x -> acc + f x) (sizeOf (undefined :: Int)) t {-# INLINE sizeSequence #-} -- | Implement 'poke' for an 'IsSequence' of 'Store' instances. -- -- Note that many monomorphic containers have more efficient -- implementations (for example, via memcpy). pokeSequence :: (IsSequence t, Store (Element t)) => t -> Poke () pokeSequence t = do pokeStorable len Poke (\ptr offset -> do offset' <- ofoldlM (\offset' a -> do (offset'',_) <- runPoke (poke a) ptr offset' return offset'') offset t return (offset',())) where len = olength t {-# INLINE pokeSequence #-} -- | Implement 'peek' for an 'IsSequence' of 'Store' instances. -- -- Note that many monomorphic containers have more efficient -- implementations (for example, via memcpy). peekSequence :: (IsSequence t, Store (Element t), Index t ~ Int) => Peek t peekSequence = do len <- peek replicateM len peek {-# INLINE peekSequence #-} ------------------------------------------------------------------------ -- Utilities for defining list-like 'Store' instances in terms of 'IsSet' -- | Implement 'size' for an 'IsSet' of 'Store' instances. sizeSet :: forall t. (IsSet t, Store (Element t)) => Size t sizeSet = VarSize $ \t -> case size :: Size (Element t) of ConstSize n -> n * (olength t) + sizeOf (undefined :: Int) VarSize f -> ofoldl' (\acc x -> acc + f x) (sizeOf (undefined :: Int)) t {-# INLINE sizeSet #-} -- | Implement 'poke' for an 'IsSequence' of 'Store' instances. pokeSet :: (IsSet t, Store (Element t)) => t -> Poke () pokeSet t = do pokeStorable (olength t) omapM_ poke t {-# INLINE pokeSet #-} -- | Implement 'peek' for an 'IsSequence' of 'Store' instances. peekSet :: (IsSet t, Store (Element t)) => Peek t peekSet = do len <- peek setFromList <$> replicateM len peek {-# INLINE peekSet #-} ------------------------------------------------------------------------ -- Utilities for defining list-like 'Store' instances in terms of a 'IsMap' -- | Implement 'size' for an 'IsMap' of where both 'ContainerKey' and -- 'MapValue' are 'Store' instances. sizeMap :: forall t. (Store (ContainerKey t), Store (MapValue t), IsMap t) => Size t sizeMap = VarSize $ \t -> case (size :: Size (ContainerKey t), size :: Size (MapValue t)) of (ConstSize nk, ConstSize na) -> (nk + na) * olength t + sizeOf (undefined :: Int) (szk, sza) -> ofoldl' (\acc (k, a) -> acc + getSizeWith szk k + getSizeWith sza a) (sizeOf (undefined :: Int)) (mapToList t) {-# INLINE sizeMap #-} -- | Implement 'poke' for an 'IsMap' of where both 'ContainerKey' and -- 'MapValue' are 'Store' instances. pokeMap :: (Store (ContainerKey t), Store (MapValue t), IsMap t) => t -> Poke () pokeMap = pokeSequence . mapToList {-# INLINE pokeMap #-} -- | Implement 'peek' for an 'IsMap' of where both 'ContainerKey' and -- 'MapValue' are 'Store' instances. peekMap :: (Store (ContainerKey t), Store (MapValue t), IsMap t) => Peek t peekMap = mapFromList <$> peek {-# INLINE peekMap #-} ------------------------------------------------------------------------ -- Utilities for defining 'Store' instances for ordered containers like -- 'IntMap' and 'Map' -- | Marker for maps that are encoded in ascending order instead of the -- descending order mistakenly implemented in 'peekMap' in store versions -- < 0.4. -- -- See https://github.com/fpco/store/issues/97. markMapPokedInAscendingOrder :: Word32 markMapPokedInAscendingOrder = 1217678090 -- | Ensure the presence of a given magic value. -- -- Throws a 'PeekException' if the value isn't present. peekMagic :: (Eq a, Show a, Store a) => String -> a -> Peek () peekMagic markedThing x = do x' <- peek when (x' /= x) $ fail ("Expected marker for " ++ markedThing ++ ": " ++ show x ++ " but got: " ++ show x') {-# INLINE peekMagic #-} -- | Like 'sizeMap' but should only be used for ordered containers where -- 'Data.Containers.mapToList' returns an ascending list. sizeOrdMap :: forall t. (Store (ContainerKey t), Store (MapValue t), IsMap t) => Size t sizeOrdMap = combineSizeWith (const markMapPokedInAscendingOrder) id size sizeMap {-# INLINE sizeOrdMap #-} -- | Like 'pokeMap' but should only be used for ordered containers where -- 'Data.Containers.mapToList' returns an ascending list. pokeOrdMap :: (Store (ContainerKey t), Store (MapValue t), IsMap t) => t -> Poke () pokeOrdMap x = poke markMapPokedInAscendingOrder >> pokeMap x {-# INLINE pokeOrdMap #-} -- | Decode the results of 'pokeOrdMap' using a given function to construct -- the map. peekOrdMapWith :: (Store (ContainerKey t), Store (MapValue t)) => ([(ContainerKey t, MapValue t)] -> t) -- ^ A function to construct the map from an ascending list such as -- 'Map.fromDistinctAscList'. -> Peek t peekOrdMapWith f = do peekMagic "ascending Map / IntMap" markMapPokedInAscendingOrder f <$> peek {-# INLINE peekOrdMapWith #-} ------------------------------------------------------------------------ -- Utilities for implementing 'Store' instances for list-like mutable things -- | Implementation of peek for mutable sequences. The user provides a -- function for initializing the sequence and a function for mutating an -- element at a particular index. peekMutableSequence :: Store a => (Int -> IO r) -> (r -> Int -> a -> IO ()) -> Peek r peekMutableSequence new write = do n <- peek mut <- liftIO (new n) forM_ [0..n-1] $ \i -> peek >>= liftIO . write mut i return mut {-# INLINE peekMutableSequence #-} ------------------------------------------------------------------------ -- Useful combinators -- | Skip n bytes forward. {-# INLINE skip #-} skip :: Int -> Peek () skip len = Peek $ \ps ptr -> do let ptr2 = ptr `plusPtr` len remaining = peekStateEndPtr ps `minusPtr` ptr when (len > remaining) $ -- Do not perform the check on the new pointer, since it could have overflowed tooManyBytes len remaining "skip" return $ PeekResult ptr2 () -- | Isolate the input to n bytes, skipping n bytes forward. Fails if @m@ -- advances the offset beyond the isolated region. {-# INLINE isolate #-} isolate :: Int -> Peek a -> Peek a isolate len m = Peek $ \ps ptr -> do let end = peekStateEndPtr ps ptr2 = ptr `plusPtr` len remaining = end `minusPtr` ptr when (len > remaining) $ -- Do not perform the check on the new pointer, since it could have overflowed tooManyBytes len remaining "isolate" PeekResult ptr' x <- runPeek m ps ptr when (ptr' > end) $ throwIO $ PeekException (ptr' `minusPtr` end) "Overshot end of isolated bytes" return $ PeekResult ptr2 x ------------------------------------------------------------------------ -- Instances for types based on flat representations instance Store a => Store (V.Vector a) where size = sizeSequence poke = pokeSequence peek = V.unsafeFreeze =<< peekMutableSequence MV.new MV.write instance Storable a => Store (SV.Vector a) where size = VarSize $ \x -> sizeOf (undefined :: Int) + sizeOf (undefined :: a) * SV.length x poke x = do let (fptr, len) = SV.unsafeToForeignPtr0 x poke len pokeFromForeignPtr fptr 0 (sizeOf (undefined :: a) * len) peek = do len <- peek fp <- peekToPlainForeignPtr "Data.Storable.Vector.Vector" (sizeOf (undefined :: a) * len) liftIO $ SV.unsafeFreeze (MSV.MVector len fp) instance Store BS.ByteString where size = VarSize $ \x -> sizeOf (undefined :: Int) + BS.length x poke x = do let (sourceFp, sourceOffset, sourceLength) = BS.toForeignPtr x poke sourceLength pokeFromForeignPtr sourceFp sourceOffset sourceLength peek = do len <- peek fp <- peekToPlainForeignPtr "Data.ByteString.ByteString" len return (BS.PS fp 0 len) #if MIN_VERSION_template_haskell(2,16,0) -- | Template Haskell Bytes are nearly identical to ByteString, but it -- can't depend on ByteString. instance Store Bytes where size = VarSize $ \x -> sizeOf (undefined :: Int) + fromIntegral (bytesSize x) poke (Bytes sourceFp sourceOffset sourceLength) = do poke sourceLength pokeFromForeignPtr sourceFp (fromIntegral sourceOffset) (fromIntegral sourceLength) peek = do len <- peek fp <- peekToPlainForeignPtr "Data.ByteString.ByteString" (fromIntegral len) return (Bytes fp 0 len) #endif instance Store SBS.ShortByteString where size = VarSize $ \x -> sizeOf (undefined :: Int) + SBS.length x poke x@(SBS.SBS arr) = do let len = SBS.length x poke len pokeFromByteArray arr 0 len peek = do len <- peek ByteArray array <- peekToByteArray "Data.ByteString.Short.ShortByteString" len return (SBS.SBS array) instance Store LBS.ByteString where size = VarSize $ \x -> sizeOf (undefined :: Int) + fromIntegral (LBS.length x) -- TODO: more efficient implementation that avoids the double copy poke = poke . LBS.toStrict peek = fmap LBS.fromStrict peek instance Store T.Text where #if MIN_VERSION_text(2,0,0) size = VarSize $ \x -> sizeOf (undefined :: Int) + T.lengthWord8 x poke x = do let !(T.Text (TA.ByteArray array) w8Off w8Len) = x poke w8Len pokeFromByteArray array w8Off w8Len peek = do w8Len <- peek ByteArray array <- peekToByteArray "Data.Text.Text" w8Len return (T.Text (TA.ByteArray array) 0 w8Len) #else size = VarSize $ \x -> sizeOf (undefined :: Int) + 2 * (T.lengthWord16 x) poke x = do let !(T.Text (TA.Array array) w16Off w16Len) = x poke w16Len pokeFromByteArray array (2 * w16Off) (2 * w16Len) peek = do w16Len <- peek ByteArray array <- peekToByteArray "Data.Text.Text" (2 * w16Len) return (T.Text (TA.Array array) 0 w16Len) #endif ------------------------------------------------------------------------ -- Known size instances newtype StaticSize (n :: Nat) a = StaticSize { unStaticSize :: a } deriving (Eq, Show, Ord, Data, Typeable, Generic) instance NFData a => NFData (StaticSize n a) class KnownNat n => IsStaticSize n a where toStaticSize :: a -> Maybe (StaticSize n a) toStaticSizeEx :: IsStaticSize n a => a -> StaticSize n a toStaticSizeEx x = case toStaticSize x of Just r -> r Nothing -> error "Failed to assert a static size via toStaticSizeEx" instance KnownNat n => IsStaticSize n BS.ByteString where toStaticSize bs | BS.length bs == fromInteger (natVal (Proxy :: Proxy n)) = Just (StaticSize bs) | otherwise = Nothing instance KnownNat n => Store (StaticSize n BS.ByteString) where size = ConstSize (fromInteger (natVal (Proxy :: Proxy n))) poke (StaticSize x) = do let (sourceFp, sourceOffset, sourceLength) = BS.toForeignPtr x pokeFromForeignPtr sourceFp sourceOffset sourceLength peek = do let len = fromInteger (natVal (Proxy :: Proxy n)) fp <- peekToPlainForeignPtr ("StaticSize " ++ show len ++ " Data.ByteString.ByteString") len return (StaticSize (BS.PS fp 0 len)) -- NOTE: this could be a 'Lift' instance, but we can't use type holes in -- TH. Alternatively we'd need a (TypeRep -> Type) function and Typeable -- constraint. liftStaticSize :: forall n a. (KnownNat n, Lift a) => TypeQ -> StaticSize n a -> ExpQ liftStaticSize tyq (StaticSize x) = do let numTy = litT $ numTyLit $ natVal (Proxy :: Proxy n) [| StaticSize $(lift x) :: StaticSize $(numTy) $(tyq) |] #if MIN_VERSION_template_haskell(2,17,0) staticByteStringExp :: Quote m => BS.ByteString -> m Exp #else staticByteStringExp :: BS.ByteString -> ExpQ #endif staticByteStringExp bs = [| StaticSize bs :: StaticSize $(litT (numTyLit (fromIntegral len))) BS.ByteString |] where len = BS.length bs ------------------------------------------------------------------------ -- containers instances instance Store a => Store [a] where size = sizeSequence poke = pokeSequence peek = peekSequence instance Store a => Store (NE.NonEmpty a) instance Store a => Store (Seq a) where size = sizeSequence poke = pokeSequence peek = peekSequence instance (Store a, Ord a) => Store (Set a) where size = VarSize $ \t -> sizeOf (undefined :: Int) + case size of ConstSize n -> n * Set.size t VarSize f -> Set.foldl' (\acc a -> acc + f a) 0 t poke = pokeSet peek = Set.fromDistinctAscList <$> peek instance Store IntSet where size = sizeSet poke = pokeSet peek = IntSet.fromDistinctAscList <$> peek instance Store a => Store (IntMap a) where size = sizeOrdMap poke = pokeOrdMap peek = peekOrdMapWith IntMap.fromDistinctAscList instance (Ord k, Store k, Store a) => Store (Map k a) where size = VarSize $ \t -> sizeOf markMapPokedInAscendingOrder + sizeOf (undefined :: Int) + case (size, size) of (ConstSize nk, ConstSize na) -> (nk + na) * Map.size t (szk, sza) -> Map.foldlWithKey' (\acc k a -> acc + getSizeWith szk k + getSizeWith sza a) 0 t poke = pokeOrdMap peek = peekOrdMapWith Map.fromDistinctAscList instance (Eq k, Hashable k, Store k, Store a) => Store (HashMap k a) where size = sizeMap poke = pokeMap peek = peekMap instance (Eq a, Hashable a, Store a) => Store (HashSet a) where size = sizeSet poke = pokeSet peek = peekSet instance (A.Ix i, Store i, Store e) => Store (A.Array i e) where size = sizeArray poke = pokeArray peek = peekArray instance (A.Ix i, A.IArray A.UArray e, Store i, Store e) => Store (A.UArray i e) where size = sizeArray poke = pokeArray peek = peekArray sizeArray :: (A.Ix i, A.IArray a e, Store i, Store e) => Size (a i e) sizeArray = VarSize $ \arr -> let bounds = A.bounds arr in getSize bounds + case size of ConstSize n -> n * A.rangeSize bounds VarSize f -> foldl' (\acc x -> acc + f x) 0 (A.elems arr) {-# INLINE sizeArray #-} pokeArray :: (A.Ix i, A.IArray a e, Store i, Store e) => a i e -> Poke () pokeArray arr = do poke (A.bounds arr) forM_ (A.elems arr) poke {-# INLINE pokeArray #-} peekArray :: (A.Ix i, A.IArray a e, Store i, Store e) => Peek (a i e) peekArray = do bounds <- peek let len = A.rangeSize bounds elems <- replicateM len peek return (A.listArray bounds elems) {-# INLINE peekArray #-} instance Store Integer where #ifdef INTEGER_GMP #if MIN_VERSION_integer_gmp(1,0,0) size = VarSize $ \ x -> sizeOf (undefined :: Word8) + case x of I.S# _ -> sizeOf (undefined :: Int) I.Jp# (I.BN# arr) -> sizeOf (undefined :: Int) + I# (sizeofByteArray# arr) I.Jn# (I.BN# arr) -> sizeOf (undefined :: Int) + I# (sizeofByteArray# arr) poke (I.S# x) = poke (0 :: Word8) >> poke (I# x) poke (I.Jp# (I.BN# arr)) = do let len = I# (sizeofByteArray# arr) poke (1 :: Word8) poke len pokeFromByteArray arr 0 len poke (I.Jn# (I.BN# arr)) = do let len = I# (sizeofByteArray# arr) poke (2 :: Word8) poke len pokeFromByteArray arr 0 len peek = do tag <- peek :: Peek Word8 case tag of 0 -> fromIntegral <$> (peek :: Peek Int) 1 -> I.Jp# <$> peekBN 2 -> I.Jn# <$> peekBN _ -> peekException "Invalid Integer tag" where peekBN = do len <- peek :: Peek Int ByteArray arr <- peekToByteArray "GHC>Integer" len return $ I.BN# arr #else -- May as well put in the extra effort to use the same encoding as -- used for the newer integer-gmp. size = VarSize $ \ x -> sizeOf (undefined :: Word8) + case x of I.S# _ -> sizeOf (undefined :: Int) I.J# sz _ -> sizeOf (undefined :: Int) + (I# sz) * sizeOf (undefined :: Word) poke (I.S# x) = poke (0 :: Word8) >> poke (I# x) poke (I.J# sz arr) | (I# sz) > 0 = do let len = I# sz * sizeOf (undefined :: Word) poke (1 :: Word8) poke len pokeFromByteArray arr 0 len | (I# sz) < 0 = do let len = negate (I# sz) * sizeOf (undefined :: Word) poke (2 :: Word8) poke len pokeFromByteArray arr 0 len | otherwise = do poke (0 :: Word8) poke (0 :: Int) peek = do tag <- peek :: Peek Word8 case tag of 0 -> fromIntegral <$> (peek :: Peek Int) 1 -> peekJ False 2 -> peekJ True _ -> peekException "Invalid Integer tag" where peekJ neg = do len <- peek :: Peek Int ByteArray arr <- peekToByteArray "GHC>Integer" len let (sz0, r) = len `divMod` (sizeOf (undefined :: Word)) !(I# sz) = if neg then negate sz0 else sz0 when (r /= 0) (peekException "Buffer size stored for encoded Integer not divisible by Word size (to get limb count).") return (I.J# sz arr) #endif #else -- NOTE: integer-simple uses a different encoding than GMP size = VarSize $ \ x -> sizeOf (undefined :: Word8) + case x of I.Positive ds -> (1 + fromIntegral (numDigits ds)) * sizeOf (undefined :: Word) I.Negative ds -> (1 + fromIntegral (numDigits ds)) * sizeOf (undefined :: Word) I.Naught -> 0 where poke x = case x of I.Naught -> poke (0 :: Word8) I.Positive ds -> do poke (1 :: Word8) poke (numDigits ds) pokeDigits ds I.Negative ds -> do poke (2 :: Word8) poke (numDigits ds) pokeDigits ds where pokeDigits I.None = pure () pokeDigits (I.Some d ds) = poke (W# d) *> pokeDigits ds peek = do tag <- peek :: Peek Word8 case tag of 0 -> pure I.Naught 1 -> do len <- peek :: Peek Word I.Positive <$> peekDigits len 2 -> do len <- peek :: Peek Word I.Negative <$> peekDigits len _ -> peekException "Invalid Integer tag" where peekDigits i | i <= 0 = pure I.None | otherwise = do W# d <- peek ds <- peekDigits (i - 1) pure $! I.Some d ds numDigits :: I.Digits -> Word numDigits = go 0 where go !acc I.None = acc go !acc (I.Some _ ds) = go (acc + 1) ds #endif -- Piggybacks off of the Integer instance instance Store Natural where size = contramap fromIntegral (size :: Size Integer) poke = poke . toInteger peek = do x <- peek :: Peek Integer if x < 0 then peekException "Encountered negative integer when expecting a Natural" else return $ fromIntegral x ------------------------------------------------------------------------ -- Other instances -- Manual implementation due to no Generic instance for Ratio. Also due -- to the instance for Storable erroring when the denominator is 0. -- Perhaps we should keep the behavior but instead a peekException? -- -- In that case it should also error on poke. -- -- I prefer being able to Store these, because they are constructable. instance Store a => Store (Ratio a) where size = combineSize (\(x :% _) -> x) (\(_ :% y) -> y) poke (x :% y) = poke (x, y) peek = uncurry (:%) <$> peek -- Similarly, manual implementation due to no Generic instance for -- Complex and Identity in GHC-7.10 and earlier. $($(derive [d| instance Deriving (Store (Fixed a)) |])) instance Store Time.DiffTime where size = contramap (realToFrac :: Time.DiffTime -> Pico) size poke = poke . (realToFrac :: Time.DiffTime -> Pico) peek = (realToFrac :: Pico -> Time.DiffTime) <$> peek instance Store Time.NominalDiffTime where size = contramap (realToFrac :: Time.NominalDiffTime -> Pico) size poke = poke . (realToFrac :: Time.NominalDiffTime -> Pico) peek = (realToFrac :: Pico -> Time.NominalDiffTime) <$> peek instance Store () instance Store a => Store (Dual a) instance Store a => Store (Sum a) instance Store a => Store (Product a) instance Store a => Store (First a) instance Store a => Store (Last a) instance Store a => Store (Maybe a) instance Store a => Store (Const a b) ------------------------------------------------------------------------ -- Instances generated by TH $($(derive [d| instance Store a => Deriving (Store (Complex a)) instance Store a => Deriving (Store (Identity a)) instance Deriving (Store All) instance Deriving (Store Any) instance Deriving (Store Void) instance Deriving (Store Bool) instance (Store a, Store b) => Deriving (Store (Either a b)) instance Deriving (Store Time.AbsoluteTime) instance Deriving (Store Time.Day) instance Deriving (Store Time.LocalTime) instance Deriving (Store Time.TimeOfDay) instance Deriving (Store Time.TimeZone) instance Deriving (Store Time.UTCTime) instance Deriving (Store Time.UniversalTime) instance Deriving (Store Time.ZonedTime) instance Deriving (Store Time.TimeLocale) #if MIN_VERSION_time(1,8,0) instance Deriving (Store Time.SystemTime) #endif #if MIN_VERSION_time(1,9,0) instance Deriving (Store Time.CalendarDiffDays) instance Deriving (Store Time.CalendarDiffTime) instance Deriving (Store Time.FormatExtension) #endif #if MIN_VERSION_time(1,11,0) instance Deriving (Store Time.DayOfWeek) instance Deriving (Store Time.FirstWeekType) instance Deriving (Store Time.Quarter) instance Deriving (Store Time.QuarterOfYear) #endif |])) $(deriveManyStorePrimVector) $(deriveManyStoreUnboxVector) $(deriveManyStoreFromStorable -- TODO: Figure out why on GHC-8.2.1 this internal datatype is visible -- in the instances of Storable. Here's a gist of an attempt at -- debugging the issue: -- -- https://gist.github.com/mgsloan/a7c416b961015949d3b5674ce053bbf6 -- -- The mysterious thing is why this is happening despite not having a -- direct import of Data.Text.Encoding. (\ty -> case ty of ConT n | nameModule n == Just "Data.Text.Encoding" && nameBase n == "DecoderState" -> False ConT n | nameModule n == Just "Data.Text.Encoding" && nameBase n == "CodePoint" -> False ConT n | nameModule n == Just "Network.Socket.Types" && nameBase n == "In6Addr" -> False -- AddrInfo's Storable instance is lossy, so avoid having a Store -- instance for it. ConT n | n == ''AddrInfo -> False _ -> True )) $(reifyManyWithoutInstances ''Store [''ModName, ''NameSpace, ''PkgName] (const True) >>= mapM (\name -> return (deriveGenericInstance [] (ConT name)))) -- Explicit definition needed because in template-haskell <= 2.9 (GHC -- 7.8), NameFlavour contains unboxed values, causing generic deriving -- to fail. #if !MIN_VERSION_template_haskell(2,10,0) instance Store NameFlavour where size = VarSize $ \x -> getSize (0 :: Word8) + case x of NameS -> 0 NameQ mn -> getSize mn NameU i -> getSize (I# i) NameL i -> getSize (I# i) NameG ns pn mn -> getSize ns + getSize pn + getSize mn poke NameS = poke (0 :: Word8) poke (NameQ mn) = do poke (1 :: Word8) poke mn poke (NameU i) = do poke (2 :: Word8) poke (I# i) poke (NameL i) = do poke (3 :: Word8) poke (I# i) poke (NameG ns pn mn) = do poke (4 :: Word8) poke ns poke pn poke mn peek = do tag <- peek case tag :: Word8 of 0 -> return NameS 1 -> NameQ <$> peek 2 -> do !(I# i) <- peek return (NameU i) 3 -> do !(I# i) <- peek return (NameL i) 4 -> NameG <$> peek <*> peek <*> peek _ -> peekException "Invalid NameFlavour tag" #endif $(reifyManyWithoutInstances ''Store [''Info] (const True) >>= mapM deriveGenericInstanceFromName) store-0.7.18/src/Data/Store/TH.hs0000644000000000000000000000542114233045224014535 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} -- | This module exports TH utilities intended to be useful to users. -- -- 'makeStore' can be used to generate a 'Store' instance for types, -- when all the type variables also require 'Store' instances. If some -- do not, then instead use "TH.Derive" like this: -- -- @ -- \{\-\# LANGUAGE TemplateHaskell \#\-\} -- \{\-\# LANGUAGE ScopedTypeVariables \#\-\} -- -- import TH.Derive -- import Data.Store -- -- data Foo a = Foo a | Bar Int -- -- \$($(derive [d| -- instance Store a => Deriving (Store (Foo a)) -- |])) -- @ -- -- Note that when used with datatypes that require type variables, the -- ScopedTypeVariables extension is required. -- -- One advantage of using this Template Haskell definition of Store -- instances is that in some cases they can be faster than the instances -- defined via Generics. Specifically, sum types which can yield -- 'ConstSize' from 'size' will be faster when used in array-like types. -- The instances generated via generics always use 'VarSize' for sum -- types. module Data.Store.TH ( makeStore -- * Testing Store instances , smallcheckManyStore , checkRoundtrip , assertRoundtrip ) where import qualified Control.Monad.Fail as Fail import Data.Complex () import Data.Store.Impl import Data.Typeable (Typeable, typeOf) import Debug.Trace (trace) import Language.Haskell.TH import Prelude import Test.Hspec import Test.Hspec.SmallCheck (property) import Test.SmallCheck import Data.Store.TH.Internal (makeStore) ------------------------------------------------------------------------ -- Testing -- | Test a 'Store' instance using 'smallcheck' and 'hspec'. smallcheckManyStore :: Bool -> Int -> [TypeQ] -> ExpQ smallcheckManyStore verbose depth = smallcheckMany . map testRoundtrip where testRoundtrip tyq = do ty <- tyq expr <- [e| property $ changeDepth (\_ -> depth) $ \x -> checkRoundtrip verbose (x :: $(return ty)) |] return ("Roundtrips (" ++ pprint ty ++ ")", expr) assertRoundtrip :: (Eq a, Show a, Store a, Fail.MonadFail m, Typeable a) => Bool -> a -> m () assertRoundtrip verbose x | checkRoundtrip verbose x = return () | otherwise = fail $ "Failed to roundtrip " ++ show (typeOf x) -- | Check if a given value succeeds in decoding its encoded -- representation. checkRoundtrip :: (Eq a, Show a, Store a) => Bool -> a -> Bool checkRoundtrip verbose x = decoded == Right x where encoded = verboseTrace verbose "encoded" (encode x) decoded = verboseTrace verbose "decoded" (decode encoded) smallcheckMany :: [Q (String, Exp)] -> ExpQ smallcheckMany = doE . map (\f -> f >>= \(name, expr) -> noBindS [e| it name $ $(return expr) |]) verboseTrace :: Show a => Bool -> String -> a -> a verboseTrace True msg x = trace (show (msg, x)) x verboseTrace False _ x = x store-0.7.18/src/Data/Store/TH/Internal.hs0000644000000000000000000004316014272422325016317 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ParallelListComp #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Store.TH.Internal ( -- * TH functions for generating Store instances deriveManyStoreFromStorable , deriveTupleStoreInstance , deriveGenericInstance , deriveGenericInstanceFromName , deriveManyStorePrimVector , deriveManyStoreUnboxVector , deriveStore , makeStore -- * Misc utilties used in Store test , getAllInstanceTypes1 , isMonoType ) where import Control.Applicative import Data.Complex () import Data.Generics.Aliases (extT, mkQ, extQ) import Data.Generics.Schemes (listify, everywhere, something) import Data.List (find) import qualified Data.Map as M import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Primitive.ByteArray import Data.Primitive.Types import Data.Store.Core import Data.Store.Impl import qualified Data.Text as T import Data.Traversable (forM) import qualified Data.Vector.Primitive as PV import qualified Data.Vector.Unboxed as UV import Data.Word import Foreign.Storable (Storable) import GHC.Types (Int(..)) import Language.Haskell.TH import Language.Haskell.TH.ReifyMany.Internal (TypeclassInstance(..), getInstances, unAppsT) import Language.Haskell.TH.Syntax (lift) import Prelude import Safe (headMay) import TH.Derive (Deriver(..)) import TH.ReifySimple import TH.Utilities (expectTyCon1, dequalify, plainInstanceD, appsT) instance Deriver (Store a) where runDeriver _ preds ty = do argTy <- expectTyCon1 ''Store ty dt <- reifyDataTypeSubstituted argTy (:[]) <$> deriveStore preds argTy (dtCons dt) -- | Given the name of a type, generate a Store instance for it, -- assuming that all type variables also need to be Store instances. -- -- Note that when used with datatypes that require type variables, the -- ScopedTypeVariables extension is required. makeStore :: Name -> Q [Dec] makeStore name = do dt <- reifyDataType name let preds = map (storePred . VarT) (dtTvs dt) argTy = appsT (ConT name) (map VarT (dtTvs dt)) (:[]) <$> deriveStore preds argTy (dtCons dt) deriveStore :: Cxt -> Type -> [DataCon] -> Q Dec deriveStore preds headTy cons0 = makeStoreInstance preds headTy <$> sizeExpr <*> peekExpr <*> pokeExpr where cons :: [(Name, [(Name, Type)])] cons = [ ( dcName dc , [ (mkName ("c" ++ show ixc ++ "f" ++ show ixf), ty) | ixf <- ints | (_, ty) <- dcFields dc ] ) | ixc <- ints | dc <- cons0 ] -- NOTE: tag code duplicated in th-storable. (tagType, _, tagSize) = fromMaybe (error "Too many constructors") $ find (\(_, maxN, _) -> maxN >= length cons) tagTypes tagTypes :: [(Name, Int, Int)] tagTypes = [ ('(), 1, 0) , (''Word8, fromIntegral (maxBound :: Word8), 1) , (''Word16, fromIntegral (maxBound :: Word16), 2) , (''Word32, fromIntegral (maxBound :: Word32), 4) , (''Word64, fromIntegral (maxBound :: Word64), 8) ] fName ix = mkName ("f" ++ show ix) ints = [0..] :: [Int] fNames = map fName ints sizeNames = zipWith (\_ -> mkName . ("sz" ++) . show) cons ints tagName = mkName "tag" valName = mkName "val" sizeExpr -- Maximum size of GHC tuples | length cons <= 62 = caseE (tupE (concatMap (map sizeAtType . snd) cons)) (case cons of -- Avoid overlapping matches when the case expression is () [] -> [matchConstSize] [c] | null (snd c) -> [matchConstSize] _ -> [matchConstSize, matchVarSize]) | otherwise = varSizeExpr where sizeAtType :: (Name, Type) -> ExpQ sizeAtType (_, ty) = [| size :: Size $(return ty) |] matchConstSize :: MatchQ matchConstSize = do let sz0 = VarE (mkName "sz0") sizeDecls = if null sizeNames then [valD (varP (mkName "sz0")) (normalB [| 0 |]) []] else zipWith constSizeDec sizeNames cons sameSizeExpr <- case sizeNames of (_ : tailSizeNames) -> foldl (\l r -> [| $(l) && $(r) |]) [| True |] $ map (\szn -> [| $(return sz0) == $(varE szn) |]) tailSizeNames [] -> [| True |] result <- [| ConstSize (tagSize + $(return sz0)) |] match (tupP (map (\(n, _) -> conP 'ConstSize [varP n]) (concatMap snd cons))) (guardedB [return (NormalG sameSizeExpr, result)]) sizeDecls constSizeDec :: Name -> (Name, [(Name, Type)]) -> DecQ constSizeDec szn (_, []) = valD (varP szn) (normalB [| 0 |]) [] constSizeDec szn (_, fields) = valD (varP szn) body [] where body = normalB $ foldl1 (\l r -> [| $(l) + $(r) |]) $ map (\(sizeName, _) -> varE sizeName) fields matchVarSize :: MatchQ matchVarSize = do match (tupP (map (\(n, _) -> varP n) (concatMap snd cons))) (normalB varSizeExpr) [] varSizeExpr :: ExpQ varSizeExpr = [| VarSize $ \x -> tagSize + $(caseE [| x |] (map matchVar cons)) |] matchVar :: (Name, [(Name, Type)]) -> MatchQ matchVar (cname, []) = match (conP cname []) (normalB [| 0 |]) [] matchVar (cname, fields) = match (conP cname (zipWith (\_ fn -> varP fn) fields fNames)) body [] where body = normalB $ foldl1 (\l r -> [| $(l) + $(r) |]) (zipWith (\(sizeName, _) fn -> [| getSizeWith $(varE sizeName) $(varE fn) |]) fields fNames) -- Choose a tag size large enough for this constructor count. -- Expression used for the definition of peek. peekExpr = case cons of [] -> [| error ("Attempting to peek type with no constructors (" ++ $(lift (show headTy)) ++ ")") |] [con] -> peekCon con _ -> doE [ bindS (varP tagName) [| peek |] , noBindS (caseE (sigE (varE tagName) (conT tagType)) (map peekMatch (zip [0..] cons) ++ [peekErr])) ] peekMatch (ix, con) = match (litP (IntegerL ix)) (normalB (peekCon con)) [] peekErr = match wildP (normalB [| peekException $ T.pack $ "Found invalid tag while peeking (" ++ $(lift (show headTy)) ++ ")" |]) [] peekCon (cname, fields) = case fields of [] -> [| pure $(conE cname) |] _ -> doE $ map (\(fn, _) -> bindS (varP fn) [| peek |]) fields ++ [noBindS $ appE (varE 'return) $ appsE $ conE cname : map (\(fn, _) -> varE fn) fields] pokeExpr = lamE [varP valName] $ caseE (varE valName) $ zipWith pokeCon [0..] cons pokeCon :: Int -> (Name, [(Name, Type)]) -> MatchQ pokeCon ix (cname, fields) = match (conP cname (map (\(fn, _) -> varP fn) fields)) body [] where body = normalB $ case cons of (_:_:_) -> doE (pokeTag ix : map pokeField fields) _ -> doE (map pokeField fields) pokeTag ix = noBindS [| poke (ix :: $(conT tagType)) |] pokeField (fn, _) = noBindS [| poke $(varE fn) |] {- What the generated code looks like data Foo = Foo Int Double Float instance Store Foo where size = case (size :: Size Int, size :: Size Double, size :: Size Float) of (ConstSize c0f0, ConstSize c0f1, ConstSize c0f2) -> ConstSize (0 + sz0) where sz0 = c0f0 + c0f1 + c0f2 (c0f0, c0f1, c0f2) VarSize $ \(Foo f0 f1 f2) -> 0 + getSizeWith c0f0 f0 + getSizeWith c0f1 f1 + getSizeWith c0f2 f2 peek = do f0 <- peek f1 <- peek f2 <- peek return (Foo f0 f1 f2) poke (Foo f0 f1 f2) = do poke f0 poke f1 poke f2 data Bar = Bar Int | Baz Double instance Store Bar where size = case (size :: Size Int, size :: Size Double) of (ConstSize c0f0, ConstSize c1f0) | sz0 == sz1 -> ConstSize (1 + sz0) where sz0 = c0f0 sz1 = c1f0 (c0f0, c1f0) -> VarSize $ \x -> 1 + case x of Bar f0 -> getSizeWith c0f0 f0 Baz f0 -> getSizeWith c1f0 f0 peek = do tag <- peek case (tag :: Word8) of 0 -> do f0 <- peek return (Bar f0) 1 -> do f0 <- peek return (Baz f0) _ -> peekException "Found invalid tag while peeking (Bar)" poke (Bar f0) = do poke 0 poke f0 poke (Bar f0) = do poke 1 poke f0 -} ------------------------------------------------------------------------ -- Generic deriveTupleStoreInstance :: Int -> Dec deriveTupleStoreInstance n = deriveGenericInstance (map storePred tvs) (foldl1 AppT (TupleT n : tvs)) where tvs = take n (map (VarT . mkName . (:[])) ['a'..'z']) deriveGenericInstance :: Cxt -> Type -> Dec deriveGenericInstance cs ty = plainInstanceD cs (AppT (ConT ''Store) ty) [] deriveGenericInstanceFromName :: Name -> Q Dec deriveGenericInstanceFromName n = do tvs <- map VarT . dtTvs <$> reifyDataType n return $ deriveGenericInstance (map storePred tvs) (appsT (ConT n) tvs) ------------------------------------------------------------------------ -- Storable -- TODO: Generate inline pragmas? Probably not necessary deriveManyStoreFromStorable :: (Type -> Bool) -> Q [Dec] deriveManyStoreFromStorable p = do storables <- postprocess . instancesMap <$> getInstances ''Storable stores <- postprocess . instancesMap <$> getInstances ''Store return $ M.elems $ flip M.mapMaybe (storables `M.difference` stores) $ \(TypeclassInstance cs ty _) -> let argTy = head (tail (unAppsT ty)) tyNameLit = LitE (StringL (pprint ty)) in if p argTy && not (superclassHasStorable cs) then Just $ makeStoreInstance cs argTy (AppE (VarE 'sizeStorableTy) tyNameLit) (AppE (VarE 'peekStorableTy) tyNameLit) (VarE 'pokeStorable) else Nothing -- See #143. Often Storable superclass constraints should instead be -- Store constraints, so instead it just warns for these. superclassHasStorable :: Cxt -> Bool superclassHasStorable = isJust . something (mkQ Nothing justStorable `extQ` ignoreStrings) where justStorable :: Type -> Maybe () justStorable (ConT n) | n == ''Storable = Just () justStorable _ = Nothing ignoreStrings :: String -> Maybe () ignoreStrings _ = Nothing ------------------------------------------------------------------------ -- Vector deriveManyStorePrimVector :: Q [Dec] deriveManyStorePrimVector = do prims <- postprocess . instancesMap <$> getInstances ''PV.Prim stores <- postprocess . instancesMap <$> getInstances ''Store let primInsts = M.mapKeys (map (AppT (ConT ''PV.Vector))) prims `M.difference` stores forM (M.toList primInsts) $ \primInst -> case primInst of ([_], TypeclassInstance cs ty _) -> do let argTy = head (tail (unAppsT ty)) sizeExpr <- [| VarSize $ \x -> I# $(primSizeOfExpr (ConT ''Int)) + I# $(primSizeOfExpr argTy) * PV.length x |] peekExpr <- [| do len <- peek let sz = I# $(primSizeOfExpr argTy) array <- peekToByteArray $(lift ("Primitive Vector (" ++ pprint argTy ++ ")")) (len * sz) return (PV.Vector 0 len array) |] pokeExpr <- [| \(PV.Vector offset len (ByteArray array)) -> do let sz = I# $(primSizeOfExpr argTy) poke len pokeFromByteArray array (offset * sz) (len * sz) |] return $ makeStoreInstance cs (AppT (ConT ''PV.Vector) argTy) sizeExpr peekExpr pokeExpr _ -> fail "Invariant violated in derivemanyStorePrimVector" primSizeOfExpr :: Type -> ExpQ primSizeOfExpr ty = [| $(varE 'sizeOf#) (error "sizeOf# evaluated its argument" :: $(return ty)) |] deriveManyStoreUnboxVector :: Q [Dec] deriveManyStoreUnboxVector = do unboxes <- getUnboxInfo stores <- postprocess . instancesMap <$> getInstances ''Store unboxInstances <- postprocess . instancesMap <$> getInstances ''UV.Unbox let dataFamilyDecls = M.fromList (map (\(preds, ty, cons) -> ([AppT (ConT ''UV.Vector) ty], (preds, cons))) unboxes) `M.difference` stores #if MIN_VERSION_template_haskell(2,10,0) substituteConstraint (AppT (ConT n) arg) | n == ''UV.Unbox = AppT (ConT ''Store) (AppT (ConT ''UV.Vector) arg) #else substituteConstraint (ClassP n [arg]) | n == ''UV.Unbox = ClassP ''Store [AppT (ConT ''UV.Vector) arg] #endif substituteConstraint x = x -- TODO: ideally this would use a variant of 'deriveStore' which -- assumes VarSize. forM (M.toList dataFamilyDecls) $ \case ([ty], (_, cons)) -> do let headTy = getTyHead (unAppsT ty !! 1) (preds, ty') <- case M.lookup [headTy] unboxInstances of Nothing -> do reportWarning $ "No Unbox instance found for " ++ pprint headTy return ([], ty) Just (TypeclassInstance cs (AppT _ ty') _) -> return (map substituteConstraint cs, AppT (ConT ''UV.Vector) ty') Just _ -> fail "Impossible case" deriveStore preds ty' cons _ -> fail "impossible case in deriveManyStoreUnboxVector" -- TODO: Add something for this purpose to TH.ReifyDataType getUnboxInfo :: Q [(Cxt, Type, [DataCon])] getUnboxInfo = do FamilyI _ insts <- reify ''UV.Vector return (map (everywhere (id `extT` dequalVarT)) $ mapMaybe go insts) where #if MIN_VERSION_template_haskell(2,15,0) go (NewtypeInstD preds _ lhs _ con _) | [_, ty] <- unAppsT lhs = toResult preds ty [con] go (DataInstD preds _ lhs _ cons _) | [_, ty] <- unAppsT lhs = toResult preds ty cons #elif MIN_VERSION_template_haskell(2,11,0) go (NewtypeInstD preds _ [ty] _ con _) = toResult preds ty [con] go (DataInstD preds _ [ty] _ cons _) = toResult preds ty cons #else go (NewtypeInstD preds _ [ty] con _) = toResult preds ty [con] go (DataInstD preds _ [ty] cons _) = toResult preds ty cons #endif go x = error ("Unexpected result from reifying Unboxed Vector instances: " ++ pprint x) toResult :: Cxt -> Type -> [Con] -> Maybe (Cxt, Type, [DataCon]) toResult _ _ [NormalC conName _] | nameBase conName `elem` skippedUnboxConstructors = Nothing toResult preds ty cons = Just (preds, ty, concatMap conToDataCons cons) dequalVarT :: Type -> Type dequalVarT (VarT n) = VarT (dequalify n) dequalVarT ty = ty -- See issue #174 skippedUnboxConstructors :: [String] skippedUnboxConstructors = ["MV_UnboxAs", "V_UnboxAs", "MV_UnboxViaPrim", "V_UnboxViaPrim"] ------------------------------------------------------------------------ -- Utilities -- Filters out overlapping instances and instances with more than one -- type arg (should be impossible). postprocess :: M.Map [Type] [a] -> M.Map [Type] a postprocess = M.mapMaybeWithKey $ \tys xs -> case (tys, xs) of ([_ty], [x]) -> Just x _ -> Nothing makeStoreInstance :: Cxt -> Type -> Exp -> Exp -> Exp -> Dec makeStoreInstance cs ty sizeExpr peekExpr pokeExpr = plainInstanceD cs (AppT (ConT ''Store) ty) [ ValD (VarP 'size) (NormalB sizeExpr) [] , ValD (VarP 'peek) (NormalB peekExpr) [] , ValD (VarP 'poke) (NormalB pokeExpr) [] ] -- TODO: either generate random types that satisfy instances with -- variables in them, or have a check that there's at least a manual -- check for polymorphic instances. getAllInstanceTypes :: Name -> Q [[Type]] getAllInstanceTypes n = map (\(TypeclassInstance _ ty _) -> drop 1 (unAppsT ty)) <$> getInstances n getAllInstanceTypes1 :: Name -> Q [Type] getAllInstanceTypes1 n = fmap (fmap (fromMaybe (error "getAllMonoInstances1 expected only one type argument") . headMay)) (getAllInstanceTypes n) isMonoType :: Type -> Bool isMonoType = null . listify isVarT isVarT :: Type -> Bool isVarT VarT{} = True isVarT _ = False -- TOOD: move these to th-reify-many -- | Get a map from the 'getTyHead' type of instances to -- 'TypeclassInstance'. instancesMap :: [TypeclassInstance] -> M.Map [Type] [TypeclassInstance] instancesMap = M.fromListWith (++) . map (\ti -> (map getTyHead (instanceArgTypes ti), [ti])) instanceArgTypes :: TypeclassInstance -> [Type] instanceArgTypes (TypeclassInstance _ ty _) = drop 1 (unAppsT ty) getTyHead :: Type -> Type getTyHead (SigT x _) = getTyHead x getTyHead (ForallT _ _ x) = getTyHead x getTyHead (AppT l _) = getTyHead l getTyHead x = x storePred :: Type -> Pred storePred ty = #if MIN_VERSION_template_haskell(2,10,0) AppT (ConT ''Store) ty #else ClassP ''Store [ty] #endif store-0.7.18/src/Data/Store/TypeHash.hs0000644000000000000000000000073314507702646015764 0ustar0000000000000000-- | This module provides utilities for computing hashes based on the -- structural definitions of datatypes. The purpose of this is to -- provide a mechanism for tagging serialized data in such a way that -- deserialization issues can be anticipated. module Data.Store.TypeHash ( Tagged(..) , TypeHash , HasTypeHash(..) -- * TH for generating HasTypeHash instances , mkHasTypeHash , mkManyHasTypeHash ) where import Data.Store.TypeHash.Internal store-0.7.18/src/Data/Store/TypeHash/Internal.hs0000644000000000000000000001151014233045224017517 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StandaloneDeriving #-} module Data.Store.TypeHash.Internal where import Control.Applicative import Control.DeepSeq (NFData) import Control.Monad (when, unless) import qualified Crypto.Hash.SHA1 as SHA1 import qualified Data.ByteString as BS import Data.Char (isUpper, isLower) import Data.Data (Data) import Data.Functor.Contravariant import Data.Generics (listify) import Data.List (sortBy) import Data.Monoid ((<>)) import Data.Ord (comparing) import Data.Proxy (Proxy(..)) import Data.Store import Data.Store.Internal import Data.Typeable (Typeable) import GHC.Generics (Generic) import Language.Haskell.TH import Language.Haskell.TH.ReifyMany (reifyMany) import Language.Haskell.TH.Syntax (Lift(..), unsafeTExpCoerce) 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) instance NFData a => NFData (Tagged a) instance (Store a, HasTypeHash a) => Store (Tagged a) where size = addSize 20 (contramap unTagged size) peek = do tag <- peek let expected = typeHash (Proxy :: Proxy a) when (tag /= expected) $ fail "Mismatched type hash" Tagged <$> peek poke (Tagged x) = do poke (typeHash (Proxy :: Proxy a)) poke x newtype TypeHash = TypeHash { unTypeHash :: StaticSize 20 BS.ByteString } deriving (Eq, Ord, Show, Store, Generic) #if __GLASGOW_HASKELL__ >= 710 deriving instance Typeable TypeHash deriving instance Data TypeHash #endif instance NFData TypeHash instance Lift TypeHash where lift = staticByteStringExp . unStaticSize . unTypeHash #if MIN_VERSION_template_haskell(2,17,0) liftTyped = Code . unsafeTExpCoerce . lift #elif MIN_VERSION_template_haskell(2,16,0) liftTyped = unsafeTExpCoerce . lift #endif reifyManyTyDecls :: ((Name, Info) -> Q (Bool, [Name])) -> [Name] -> Q [(Name, Info)] reifyManyTyDecls f = reifyMany go where go x@(_, TyConI{}) = f x go x@(_, FamilyI{}) = f x go x@(_, PrimTyConI{}) = f x go x@(_, DataConI{}) = f x go (_, ClassI{}) = return (False, []) go (_, ClassOpI{}) = return (False, []) go (_, VarI{}) = return (False, []) go (_, TyVarI{}) = return (False, []) #if MIN_VERSION_template_haskell(2,12,0) go (_, PatSynI{}) = return (False, []) #endif -- | At compiletime, this yields a hash of the specified datatypes. -- Not only does this cover the datatypes themselves, but also all -- transitive dependencies. -- -- The resulting expression is a literal of type 'TypeHash'. typeHashForNames :: [Name] -> Q Exp typeHashForNames ns = do infos <- getTypeInfosRecursively ns [| TypeHash $(staticByteStringExp (SHA1.hash (encode infos))) |] -- | At compiletime, this yields a cryptographic hash of the specified 'Type', -- including the definition of things it references (transitively). -- -- The resulting expression is a literal of type 'TypeHash'. hashOfType :: Type -> Q Exp hashOfType ty = do unless (null (getVarNames ty)) $ fail $ "hashOfType cannot handle polymorphic type " <> pprint ty infos <- getTypeInfosRecursively (getConNames ty) [| TypeHash $(staticByteStringExp (SHA1.hash (encode infos))) |] getTypeInfosRecursively :: [Name] -> Q [(Name, Info)] getTypeInfosRecursively names = do allInfos <- reifyManyTyDecls (\(_, info) -> return (True, getConNames info)) names -- Sorting step probably unnecessary because this should be -- deterministic, but hey why not. return (sortBy (comparing fst) allInfos) getConNames :: Data a => a -> [Name] getConNames = listify (isUpper . head . nameBase) getVarNames :: Data a => a -> [Name] getVarNames = listify (isLower . head . nameBase) -- TODO: Generic instance for polymorphic types, or have TH generate -- polymorphic instances. class HasTypeHash a where typeHash :: Proxy a -> TypeHash mkHasTypeHash :: Type -> Q [Dec] mkHasTypeHash ty = [d| instance HasTypeHash $(return ty) where typeHash _ = $(hashOfType ty) |] mkManyHasTypeHash :: [Q Type] -> Q [Dec] mkManyHasTypeHash qtys = concat <$> mapM (mkHasTypeHash =<<) qtys combineTypeHashes :: [TypeHash] -> TypeHash combineTypeHashes = TypeHash . toStaticSizeEx . SHA1.hash . BS.concat . map (unStaticSize . unTypeHash) store-0.7.18/src/Data/Store/Version.hs0000644000000000000000000002771714233045224015663 0ustar0000000000000000{-# 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(..) , VersionConfig(..) , hashedVersionConfig , namedVersionConfig , encodeWithVersionQ , decodeWithVersionQ ) where 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.Word (Word32) 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) -- | 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 } encodeWithVersionQ :: Data a => VersionConfig a -> Q Exp encodeWithVersionQ = impl Encode decodeWithVersionQ :: Data a => VersionConfig a -> Q Exp decodeWithVersionQ = impl Decode data WhichFunc = Encode | Decode 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) "" 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" let atype = typeRepToType (typeRep proxy) case wf of Encode -> [e| \x -> ( getSize markEncodedVersion + getSize $(version) + getSize x , poke markEncodedVersion >> poke $(version) >> poke (x :: $(atype))) |] Decode -> [e| do peekMagic "version tag" markEncodedVersion gotVersion <- peek if gotVersion /= $(version) then fail (displayVersionError $(version) gotVersion) else peek :: Peek $(atype) |] {- 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 [] -> error "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 showsQualTypeRep renames p tyrep = let (tycon, tys) = splitTyConApp tyrep in 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 displayVersionError :: StoreVersion -> StoreVersion -> String displayVersionError expectedVersion receivedVersion = "Mismatch detected by Data.Store.Version - expected " ++ T.unpack (decodeUtf8With lenientDecode (unStoreVersion expectedVersion)) ++ " but got " ++ T.unpack (decodeUtf8With lenientDecode (unStoreVersion receivedVersion)) markEncodedVersion :: Word32 markEncodedVersion = 3908297288 store-0.7.18/src/System/IO/ByteBuffer.hs0000644000000000000000000004233614442512103016110 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-@ LIQUID "--no-termination" @-} {-@ LIQUID "--short-names" @-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} {-| Module: System.IO.ByteBuffer Description: Provides an efficient buffering abstraction. A 'ByteBuffer' is a simple buffer for bytes. It supports two operations: refilling with the contents of a 'ByteString', and consuming a fixed number of bytes. It is implemented as a pointer, together with counters that keep track of the offset and the number of bytes in the buffer. Note that the counters are simple 'IORef's, so 'ByteBuffer's are not thread-safe! A 'ByteBuffer' is constructed by 'new' with a given starting length, and will grow (by repeatedly multiplying its size by 1.5) whenever it is being fed a 'ByteString' that is too large. -} module System.IO.ByteBuffer ( ByteBuffer -- * Allocation and Deallocation , new, free, with -- * Query for number of available bytes , totalSize, isEmpty, availableBytes -- * Feeding new input , copyByteString #ifndef mingw32_HOST_OS , fillFromFd #endif -- * Consuming bytes from the buffer , consume, unsafeConsume -- * Exceptions , ByteBufferException (..) ) where import Control.Applicative import Control.Exception (SomeException, throwIO) import Control.Exception.Lifted (Exception, bracket, catch) import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Control (MonadBaseControl) import Data.ByteString (ByteString) import qualified Data.ByteString.Internal as BS import Data.IORef import Data.Maybe (fromMaybe) import Data.Typeable (Typeable) import Data.Word import Foreign.ForeignPtr import qualified Foreign.Marshal.Alloc as Alloc import Foreign.Marshal.Utils (copyBytes, moveBytes) import GHC.Ptr import Prelude import qualified Foreign.C.Error as CE import Foreign.C.Types import System.Posix.Types (Fd (..)) -- | A buffer into which bytes can be written. -- -- Invariants: -- -- * @size >= containedBytes >= consumedBytes >= 0@ -- -- * The range from @ptr@ to @ptr `plusPtr` size@ will be allocated -- -- * The range from @ptr@ to @ptr `plusPtr` containedBytes@ will -- contain bytes previously copied to the buffer -- -- * The buffer contains @containedBytes - consumedBytes@ bytes of -- data that have been copied to it, but not yet read. They are in -- the range from @ptr `plusPtr` consumedBytes@ to @ptr `plusPtr` -- containedBytes@. -- -- The first two invariants are encoded in Liquid Haskell, and can -- be statically checked. -- -- If an Exception occurs during an operation that modifies a -- 'ByteBuffer', the 'ByteBuffer' is invalidated and can no longer be -- used. Trying to access the 'ByteBuffer' subsequently will result -- in a 'ByteBufferException' being thrown. {-@ data BBRef = BBRef { size :: {v: Int | v >= 0 } , contained :: { v: Int | v >= 0 && v <= size } , consumed :: { v: Int | v >= 0 && v <= contained } , ptr :: { v: Ptr Word8 | (plen v) = size } } @-} data BBRef = BBRef { size :: {-# UNPACK #-} !Int -- ^ The amount of memory allocated. , contained :: {-# UNPACK #-} !Int -- ^ The number of bytes that the 'ByteBuffer' currently holds. , consumed :: {-# UNPACK #-} !Int -- ^ The number of bytes that have already been consumed. , ptr :: {-# UNPACK #-} !(Ptr Word8) -- ^ This points to the beginning of the memory allocated for -- the 'ByteBuffer' } -- | Exception that is thrown when an invalid 'ByteBuffer' is being used that is no longer valid. -- -- A 'ByteBuffer' is considered to be invalid if -- -- - it has explicitly been freed -- - an Exception has occured during an operation that modified it data ByteBufferException = ByteBufferException { _bbeLocation :: !String -- ^ function name that caused the exception , _bbeException :: !String -- ^ printed representation of the exception } deriving (Typeable, Eq) instance Show ByteBufferException where show (ByteBufferException loc e) = concat ["ByteBufferException: ByteBuffer was invalidated because of Exception thrown in " , loc , ": ", e] instance Exception ByteBufferException type ByteBuffer = IORef (Either ByteBufferException BBRef) -- | On any Exception, this will invalidate the ByteBuffer and re-throw the Exception. -- -- Invalidating the 'ByteBuffer' includes freeing the underlying pointer. bbHandler :: MonadIO m => String -- ^ location information: function from which the exception was thrown -> ByteBuffer -- ^ this 'ByteBuffer' will be invalidated when an Exception occurs -> (BBRef -> IO a) -> m a bbHandler loc bb f = liftIO $ useBBRef f bb `catch` \(e :: SomeException) -> do readIORef bb >>= \case Right bbref -> do Alloc.free (ptr bbref) writeIORef bb (Left $ ByteBufferException loc (show e)) Left _ -> return () throwIO e -- | Try to use the 'BBRef' of a 'ByteBuffer', or throw a 'ByteBufferException' if it's invalid. useBBRef :: (BBRef -> IO a) -> ByteBuffer -> IO a useBBRef f bb = readIORef bb >>= either throwIO f {-# INLINE useBBRef #-} totalSize :: MonadIO m => ByteBuffer -> m Int totalSize = liftIO . useBBRef (return . size) {-# INLINE totalSize #-} isEmpty :: MonadIO m => ByteBuffer -> m Bool isEmpty bb = liftIO $ (==0) <$> availableBytes bb {-# INLINE isEmpty #-} -- | Number of available bytes in a 'ByteBuffer' (that is, bytes that -- have been copied to, but not yet read from the 'ByteBuffer'. {-@ availableBytes :: MonadIO m => ByteBuffer -> m {v: Int | v >= 0} @-} availableBytes :: MonadIO m => ByteBuffer -> m Int availableBytes = liftIO . useBBRef (\BBRef{..} -> return (contained - consumed)) {-# INLINE availableBytes #-} -- | Allocates a new ByteBuffer with a given buffer size filling from -- the given FillBuffer. -- -- Note that 'ByteBuffer's created with 'new' have to be deallocated -- explicitly using 'free'. For automatic deallocation, consider -- using 'with' instead. new :: MonadIO m => Maybe Int -- ^ Size of buffer to allocate. If 'Nothing', use the default -- value of 4MB -> m ByteBuffer -- ^ The byte buffer. new ml = liftIO $ do let l = max 0 . fromMaybe (4*1024*1024) $ ml newPtr <- Alloc.mallocBytes l newIORef $ Right BBRef { ptr = newPtr , size = l , contained = 0 , consumed = 0 } -- | Free a byte buffer. free :: MonadIO m => ByteBuffer -> m () free bb = liftIO $ readIORef bb >>= \case Right bbref -> do Alloc.free $ ptr bbref writeIORef bb $ Left (ByteBufferException "free" "ByteBuffer has explicitly been freed and is no longer valid.") Left _ -> return () -- the ByteBuffer is either invalid or has already been freed. -- | Perform some action with a bytebuffer, with automatic allocation -- and deallocation. with :: (MonadIO m, MonadBaseControl IO m) => Maybe Int -- ^ Initial length of the 'ByteBuffer'. If 'Nothing', use the -- default value of 4MB. -> (ByteBuffer -> m a) -> m a with l action = bracket (new l) free action {-# INLINE with #-} -- | Reset a 'BBRef', i.e. copy all the bytes that have not yet -- been consumed to the front of the buffer. {-@ resetBBRef :: b:BBRef -> IO {v:BBRef | consumed v == 0 && contained v == contained b - consumed b && size v == size b} @-} resetBBRef :: BBRef -> IO BBRef resetBBRef bbref = do let available = contained bbref - consumed bbref moveBytes (ptr bbref) (ptr bbref `plusPtr` consumed bbref) available return BBRef { size = size bbref , contained = available , consumed = 0 , ptr = ptr bbref } -- | Make sure the buffer is at least @minSize@ bytes long. -- -- In order to avoid having to enlarge the buffer too often, we -- multiply its size by a factor of 1.5 until it is at least @minSize@ -- bytes long. {-@ enlargeBBRef :: b:BBRef -> i:Nat -> IO {v:BBRef | size v >= i && contained v == contained b && consumed v == consumed b} @-} enlargeBBRef :: BBRef -> Int -> IO BBRef enlargeBBRef bbref minSize = do let getNewSize s | s >= minSize = s getNewSize s = getNewSize $ (ceiling . (*(1.5 :: Double)) . fromIntegral) (max 1 s) newSize = getNewSize (size bbref) -- possible optimisation: since reallocation might copy the -- bytes anyway, we could discard the consumed bytes, -- basically 'reset'ting the buffer on the fly. ptr' <- Alloc.reallocBytes (ptr bbref) newSize return BBRef { size = newSize , contained = contained bbref , consumed = consumed bbref , ptr = ptr' } -- | Copy the contents of a 'ByteString' to a 'ByteBuffer'. -- -- If necessary, the 'ByteBuffer' is enlarged and/or already consumed -- bytes are dropped. copyByteString :: MonadIO m => ByteBuffer -> ByteString -> m () copyByteString bb bs = bbHandler "copyByteString" bb go where go bbref = do let (bsFptr, bsOffset, bsSize) = BS.toForeignPtr bs -- if the byteBuffer is too small, resize it. let available = contained bbref - consumed bbref -- bytes not yet consumed bbref' <- if size bbref < bsSize + available then enlargeBBRef bbref (bsSize + available) else return bbref -- if it is currently too full, reset it bbref'' <- if bsSize + contained bbref' > size bbref' then resetBBRef bbref' else return bbref' -- now we can safely copy. withForeignPtr bsFptr $ \ bsPtr -> copyBytes (ptr bbref'' `plusPtr` contained bbref'') (bsPtr `plusPtr` bsOffset) bsSize writeIORef bb $ Right BBRef { size = size bbref'' , contained = contained bbref'' + bsSize , consumed = consumed bbref'' , ptr = ptr bbref''} #ifndef mingw32_HOST_OS -- | Will read at most n bytes from the given 'Fd', in a non-blocking -- fashion. This function is intended to be used with non-blocking 'Socket's, -- such the ones created by the @network@ package. -- -- Returns how many bytes could be read non-blockingly. fillFromFd :: (MonadIO m, Fail.MonadFail m) => ByteBuffer -> Fd -> Int -> m Int fillFromFd bb sock maxBytes = if maxBytes < 0 then fail ("fillFromFd: negative argument (" ++ show maxBytes ++ ")") else bbHandler "fillFromFd" bb go where go bbref = do (bbref', readBytes) <- fillBBRefFromFd sock bbref maxBytes writeIORef bb $ Right bbref' return readBytes {- Note: I'd like to use these two definitions: {-@ measure _available @-} _available :: BBRef -> Int _available BBRef{..} = contained - consumed {-@ measure _free @-} _free :: BBRef -> Int _free BBRef{..} = size - contained but for some reason when I try to do so it does not work. -} {-@ fillBBRefFromFd :: Fd -> b0: BBRef -> maxBytes: Nat -> IO {v: (BBRef, Nat) | maxBytes >= snd v && contained (fst v) - consumed (fst v) == contained b0 - consumed b0 + snd v} @-} fillBBRefFromFd :: Fd -> BBRef -> Int -> IO (BBRef, Int) fillBBRefFromFd (Fd sock) bbref0 maxBytes = do bbref1 <- prepareSpace bbref0 go 0 bbref1 where -- We enlarge the buffer directly to be able to contain the maximum number -- of bytes since the common pattern for this function is to know how many -- bytes we need to read -- so we'll eventually fill the enlarged buffer. {-@ prepareSpace :: b: BBRef -> IO {v: BBRef | size v - contained v >= maxBytes && contained b - consumed b == contained v - consumed v} @-} prepareSpace :: BBRef -> IO BBRef prepareSpace bbref = do let space = size bbref - contained bbref if space < maxBytes then if consumed bbref > 0 then prepareSpace =<< resetBBRef bbref else enlargeBBRef bbref (contained bbref + maxBytes) else return bbref {-@ go :: readBytes: {v: Nat | v <= maxBytes} -> b: {b: BBRef | size b - contained b >= maxBytes - readBytes} -> IO {v: (BBRef, Nat) | maxBytes >= snd v && snd v >= readBytes && size (fst v) - contained (fst v) >= maxBytes - snd v && contained (fst v) - consumed (fst v) == (contained b - consumed b) + (snd v - readBytes)} @-} go :: Int -> BBRef -> IO (BBRef, Int) go readBytes bbref@BBRef{..} = if readBytes >= maxBytes then return (bbref, readBytes) else do bytes <- fromIntegral <$> c_recv sock (castPtr (ptr `plusPtr` contained)) (fromIntegral (maxBytes - readBytes)) 0 if bytes == -1 then do err <- CE.getErrno if err == CE.eAGAIN || err == CE.eWOULDBLOCK then return (bbref, readBytes) else throwIO $ CE.errnoToIOError "ByteBuffer.fillBBRefFromFd: " err Nothing Nothing else do let bbref' = bbref{ contained = contained + bytes } go (readBytes + bytes) bbref' foreign import ccall unsafe "recv" -- c_recv returns -1 in the case of errors. {-@ assume c_recv :: CInt -> Ptr CChar -> size: {v: CSize | v >= 0} -> flags: CInt -> IO {read: CInt | read >= -1 && size >= read} @-} c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt #endif -- | Try to get a pointer to @n@ bytes from the 'ByteBuffer'. -- -- Note that the pointer should be used before any other actions are -- performed on the 'ByteBuffer'. It points to some address within the -- buffer, so operations such as enlarging the buffer or feeding it -- new data will change the data the pointer points to. This is why -- this function is called unsafe. {-@ unsafeConsume :: MonadIO m => ByteBuffer -> n:Nat -> m (Either Int ({v:Ptr Word8 | plen v >= n})) @-} unsafeConsume :: MonadIO m => ByteBuffer -> Int -- ^ n -> m (Either Int (Ptr Word8)) -- ^ Will be @Left missing@ when there are only @n-missing@ -- bytes left in the 'ByteBuffer'. unsafeConsume bb n = bbHandler "unsafeConsume" bb go where go bbref = do let available = contained bbref - consumed bbref if available < n then return $ Left (n - available) else do writeIORef bb $ Right bbref { consumed = consumed bbref + n } return $ Right (ptr bbref `plusPtr` consumed bbref) -- | As `unsafeConsume`, but instead of returning a `Ptr` into the -- contents of the `ByteBuffer`, it returns a `ByteString` containing -- the next @n@ bytes in the buffer. This involves allocating a new -- 'ByteString' and copying the @n@ bytes to it. {-@ consume :: MonadIO m => ByteBuffer -> Nat -> m (Either Int ByteString) @-} consume :: MonadIO m => ByteBuffer -> Int -> m (Either Int ByteString) consume bb n = do mPtr <- unsafeConsume bb n case mPtr of Right ptr -> do bs <- liftIO $ createBS ptr n return (Right bs) Left missing -> return (Left missing) {-@ createBS :: p:(Ptr Word8) -> {v:Nat | v <= plen p} -> IO ByteString @-} createBS :: Ptr Word8 -> Int -> IO ByteString createBS ptr n = do fp <- mallocForeignPtrBytes n withForeignPtr fp (\p -> copyBytes p ptr n) return (BS.PS fp 0 n) -- below are liquid haskell qualifiers, and specifications for external functions. {-@ qualif FPLenPLen(v:Ptr a, fp:ForeignPtr a): fplen fp = plen v @-} {-@ Foreign.Marshal.Alloc.mallocBytes :: l:Nat -> IO (PtrN a l) @-} {-@ Foreign.Marshal.Alloc.reallocBytes :: Ptr a -> l:Nat -> IO (PtrN a l) @-} {-@ assume mallocForeignPtrBytes :: n:Nat -> IO (ForeignPtrN a n) @-} {-@ type ForeignPtrN a N = {v:ForeignPtr a | fplen v = N} @-} {-@ Foreign.Marshal.Utils.copyBytes :: p:Ptr a -> q:Ptr a -> {v:Nat | v <= plen p && v <= plen q} -> IO ()@-} {-@ Foreign.Marshal.Utils.moveBytes :: p:Ptr a -> q:Ptr a -> {v:Nat | v <= plen p && v <= plen q} -> IO ()@-} {-@ Foreign.Ptr.plusPtr :: p:Ptr a -> n:Nat -> {v:Ptr b | plen v == (plen p) - n} @-} -- writing down the specification for ByteString is not as straightforward as it seems at first: the constructor -- -- PS (ForeignPtr Word8) Int Int -- -- has actually four arguments after unboxing (the ForeignPtr is an -- Addr# and ForeignPtrContents), so restriciting the length of the -- ForeignPtr directly in the specification of the datatype does not -- work. Instead, I chose to write a specification for toForeignPtr. -- It seems that the liquidhaskell parser has problems with variables -- declared in a tuple, so I have to define the following measures to -- get at the ForeignPtr, offset, and length. -- -- This is a bit awkward, maybe there is an easier way. _get1 :: (a,b,c) -> a _get1 (x,_,_) = x {-@ measure _get1 @-} _get2 :: (a,b,c) -> b _get2 (_,x,_) = x {-@ measure _get2 @-} _get3 :: (a,b,c) -> c _get3 (_,_,x) = x {-@ measure _get3 @-} {-@ Data.ByteString.Internal.toForeignPtr :: ByteString -> {v:(ForeignPtr Word8, Int, Int) | _get2 v >= 0 && _get2 v <= (fplen (_get1 v)) && _get3 v >= 0 && ((_get3 v) + (_get2 v)) <= (fplen (_get1 v))} @-} store-0.7.18/src/Data/Store/Impl.hs0000644000000000000000000003135414233045224015127 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- This module is not exposed. The reason that it is split out from -- "Data.Store.Internal" is to allow "Data.Store.TH" to refer to these -- identifiers. "Data.Store.Internal" must be separate from -- "Data.Store.TH" due to Template Haskell's stage restriction. module Data.Store.Impl where import Control.Applicative import Control.Exception (try) import Control.Monad import qualified Data.ByteString as BS import Data.Functor.Contravariant (Contravariant(..)) import Data.Proxy import Data.Store.Core import Data.Typeable (Typeable, typeRep) import Data.Word import Foreign.Storable (Storable, sizeOf) import GHC.Exts (Constraint) import GHC.Generics import GHC.TypeLits import Prelude import System.IO.Unsafe (unsafePerformIO) ------------------------------------------------------------------------ -- Store class -- | The 'Store' typeclass provides efficient serialization and -- deserialization to raw pointer addresses. -- -- The 'peek' and 'poke' methods should be defined such that -- @ decodeEx (encode x) == x @. class Store a where -- | Yields the 'Size' of the buffer, in bytes, required to store -- the encoded representation of the type. -- -- Note that the correctness of this function is crucial for the -- safety of 'poke', as it does not do any bounds checking. It is -- the responsibility of the invoker of 'poke' ('encode' and similar -- functions) to ensure that there's enough space in the output -- buffer. If 'poke' writes beyond, then arbitrary memory can be -- overwritten, causing undefined behavior and segmentation faults. size :: Size a -- | Serializes a value to bytes. It is the responsibility of the -- caller to ensure that at least the number of bytes required by -- 'size' are available. These details are handled by 'encode' and -- similar utilities. poke :: a -> Poke () -- | Serialized a value from bytes, throwing exceptions if it -- encounters invalid data or runs out of input bytes. peek :: Peek a default size :: (Generic a, GStoreSize (Rep a)) => Size a size = genericSize default poke :: (Generic a, GStorePoke (Rep a)) => a -> Poke () poke = genericPoke default peek :: (Generic a , GStorePeek (Rep a)) => Peek a peek = genericPeek -- NB: Do not INLINE the default implementations of size, poke, or peek! -- Doing so can lead to enormous memory blowup (a maximum residency of -- 5.17 GB with GHC 8.0.2 has been observed). For more information, please -- read issue #91. ------------------------------------------------------------------------ -- Utilities for encoding / decoding strict ByteStrings -- | Serializes a value to a 'BS.ByteString'. In order to do this, it -- first allocates a 'BS.ByteString' of the correct size (based on -- 'size'), and then uses 'poke' to fill it. -- -- Safety of this function depends on correctness of the 'Store' -- instance. If 'size' returns a. The good news is that this isn't an -- issue if you use well-tested manual instances (such as those from -- this package) combined with auomatic definition of instances. encode :: Store a => a -> BS.ByteString encode x = unsafeEncodeWith (poke x) (getSize x) -- | Decodes a value from a 'BS.ByteString'. Returns an exception if -- there's an error while decoding, or if decoding undershoots / -- overshoots the end of the buffer. decode :: Store a => BS.ByteString -> Either PeekException a decode = unsafePerformIO . try . decodeIO -- | Decodes a value from a 'BS.ByteString', potentially throwing -- exceptions. It is an exception to not consume all input. decodeEx :: Store a => BS.ByteString -> a decodeEx = unsafePerformIO . decodeIO -- | Decodes a value from a 'BS.ByteString', potentially throwing -- exceptions. It is an exception to not consume all input. decodeIO :: Store a => BS.ByteString -> IO a decodeIO = decodeIOWith peek ------------------------------------------------------------------------ -- Size -- | Info about a type's serialized length. Either the length is known -- independently of the value, or the length depends on the value. data Size a = VarSize (a -> Int) | ConstSize !Int deriving Typeable instance Contravariant Size where contramap f sz = case sz of ConstSize n -> ConstSize n VarSize g -> VarSize (\x -> g (f x)) -- | Get the number of bytes needed to store the given value. See -- 'size'. getSize :: Store a => a -> Int getSize = getSizeWith size {-# INLINE getSize #-} -- | Given a 'Size' value and a value of the type @a@, returns its 'Int' -- size. getSizeWith :: Size a -> a -> Int getSizeWith (VarSize f) x = f x getSizeWith (ConstSize n) _ = n {-# INLINE getSizeWith #-} -- | Create an aggregate 'Size' by providing functions to split the -- input into two pieces. -- -- If both of the types are 'ConstSize', the result is 'ConstSize' and -- the functions will not be used. combineSize :: forall a b c. (Store a, Store b) => (c -> a) -> (c -> b) -> Size c combineSize toA toB = combineSizeWith toA toB size size {-# INLINE combineSize #-} -- | Create an aggregate 'Size' by providing functions to split the -- input into two pieces, as well as 'Size' values to use to measure the -- results. -- -- If both of the input 'Size' values are 'ConstSize', the result is -- 'ConstSize' and the functions will not be used. combineSizeWith :: forall a b c. (c -> a) -> (c -> b) -> Size a -> Size b -> Size c combineSizeWith toA toB sizeA sizeB = case (sizeA, sizeB) of (VarSize f, VarSize g) -> VarSize (\x -> f (toA x) + g (toB x)) (VarSize f, ConstSize m) -> VarSize (\x -> f (toA x) + m) (ConstSize n, VarSize g) -> VarSize (\x -> n + g (toB x)) (ConstSize n, ConstSize m) -> ConstSize (n + m) {-# INLINE combineSizeWith #-} -- | Adds a constant amount to a 'Size' value. addSize :: Int -> Size a -> Size a addSize x (ConstSize n) = ConstSize (x + n) addSize x (VarSize f) = VarSize ((x +) . f) {-# INLINE addSize #-} -- | A 'size' implementation based on an instance of 'Storable' and -- 'Typeable'. sizeStorable :: forall a. (Storable a, Typeable a) => Size a sizeStorable = sizeStorableTy (show (typeRep (Proxy :: Proxy a))) {-# INLINE sizeStorable #-} -- | A 'size' implementation based on an instance of 'Storable'. Use this -- if the type is not 'Typeable'. sizeStorableTy :: forall a. Storable a => String -> Size a sizeStorableTy ty = ConstSize (sizeOf (error msg :: a)) where msg = "In Data.Store.storableSize: " ++ ty ++ "'s sizeOf evaluated its argument." {-# INLINE sizeStorableTy #-} ------------------------------------------------------------------------ -- Generics genericSize :: (Generic a, GStoreSize (Rep a)) => Size a genericSize = contramap from gsize {-# INLINE genericSize #-} genericPoke :: (Generic a, GStorePoke (Rep a)) => a -> Poke () genericPoke = gpoke . from {-# INLINE genericPoke #-} genericPeek :: (Generic a , GStorePeek (Rep a)) => Peek a genericPeek = to <$> gpeek {-# INLINE genericPeek #-} type family SumArity (a :: * -> *) :: Nat where SumArity (C1 c a) = 1 SumArity (x :+: y) = SumArity x + SumArity y -- This could be just one typeclass, but currently compile times are -- better with things split up. -- https://github.com/bos/aeson/pull/335 -- class GStoreSize f where gsize :: Size (f a) class GStorePoke f where gpoke :: f a -> Poke () class GStorePeek f where gpeek :: Peek (f a) instance GStoreSize f => GStoreSize (M1 i c f) where gsize = contramap unM1 gsize {-# INLINE gsize #-} instance GStorePoke f => GStorePoke (M1 i c f) where gpoke = gpoke . unM1 {-# INLINE gpoke #-} instance GStorePeek f => GStorePeek (M1 i c f) where gpeek = fmap M1 gpeek {-# INLINE gpeek #-} instance Store a => GStoreSize (K1 i a) where gsize = contramap unK1 size {-# INLINE gsize #-} instance Store a => GStorePoke (K1 i a) where gpoke = poke . unK1 {-# INLINE gpoke #-} instance Store a => GStorePeek (K1 i a) where gpeek = fmap K1 peek {-# INLINE gpeek #-} instance GStoreSize U1 where gsize = ConstSize 0 {-# INLINE gsize #-} instance GStorePoke U1 where gpoke _ = return () {-# INLINE gpoke #-} instance GStorePeek U1 where gpeek = return U1 {-# INLINE gpeek #-} instance GStoreSize V1 where gsize = ConstSize 0 {-# INLINE gsize #-} instance GStorePoke V1 where gpoke x = case x of {} {-# INLINE gpoke #-} instance GStorePeek V1 where gpeek = undefined {-# INLINE gpeek #-} instance (GStoreSize a, GStoreSize b) => GStoreSize (a :*: b) where gsize = combineSizeWith (\(x :*: _) -> x) (\(_ :*: y) -> y) gsize gsize {-# INLINE gsize #-} instance (GStorePoke a, GStorePoke b) => GStorePoke (a :*: b) where gpoke (a :*: b) = gpoke a >> gpoke b {-# INLINE gpoke #-} instance (GStorePeek a, GStorePeek b) => GStorePeek (a :*: b) where gpeek = (:*:) <$> gpeek <*> gpeek {-# INLINE gpeek #-} -- The machinery for sum types is why UndecidableInstances is necessary. instance (FitsInByte (SumArity (a :+: b)), GStoreSizeSum 0 (a :+: b)) => GStoreSize (a :+: b) where gsize = VarSize $ \x -> sizeOf (undefined :: Word8) + gsizeSum x (Proxy :: Proxy 0) {-# INLINE gsize #-} instance (FitsInByte (SumArity (a :+: b)), GStorePokeSum 0 (a :+: b)) => GStorePoke (a :+: b) where gpoke x = gpokeSum x (Proxy :: Proxy 0) {-# INLINE gpoke #-} instance (FitsInByte (SumArity (a :+: b)), GStorePeekSum 0 (a :+: b)) => GStorePeek (a :+: b) where gpeek = do tag <- peekStorable gpeekSum tag (Proxy :: Proxy 0) {-# INLINE gpeek #-} -- See https://github.com/fpco/store/issues/141 - this constraint type -- family machinery improves error messages for generic deriving on -- sum types with many constructors. type FitsInByte n = FitsInByteResult (n <=? 255) type family FitsInByteResult (b :: Bool) :: Constraint where FitsInByteResult 'True = () FitsInByteResult 'False = TypeErrorMessage "Generic deriving of Store instances can only be used on datatypes with fewer than 256 constructors." type family TypeErrorMessage (a :: Symbol) :: Constraint where #if MIN_VERSION_base(4,9,0) TypeErrorMessage a = TypeError ('Text a) -- GHC < 8.0 does not support empty closed type families #elif __GLASGOW_HASKELL__ < 800 TypeErrorMessage a = a ~ "" #endif -- Similarly to splitting up the generic class into multiple classes, we -- also split up the one for sum types. class KnownNat n => GStoreSizeSum (n :: Nat) (f :: * -> *) where gsizeSum :: f a -> Proxy n -> Int class KnownNat n => GStorePokeSum (n :: Nat) (f :: * -> *) where gpokeSum :: f p -> Proxy n -> Poke () class KnownNat n => GStorePeekSum (n :: Nat) (f :: * -> *) where gpeekSum :: Word8 -> Proxy n -> Peek (f p) instance (GStoreSizeSum n a, GStoreSizeSum (n + SumArity a) b, KnownNat n) => GStoreSizeSum n (a :+: b) where gsizeSum (L1 l) _ = gsizeSum l (Proxy :: Proxy n) gsizeSum (R1 r) _ = gsizeSum r (Proxy :: Proxy (n + SumArity a)) {-# INLINE gsizeSum #-} instance (GStorePokeSum n a, GStorePokeSum (n + SumArity a) b, KnownNat n) => GStorePokeSum n (a :+: b) where gpokeSum (L1 l) _ = gpokeSum l (Proxy :: Proxy n) gpokeSum (R1 r) _ = gpokeSum r (Proxy :: Proxy (n + SumArity a)) {-# INLINE gpokeSum #-} instance (GStorePeekSum n a, GStorePeekSum (n + SumArity a) b, KnownNat n) => GStorePeekSum n (a :+: b) where gpeekSum tag proxyL | tag < sizeL = L1 <$> gpeekSum tag proxyL | otherwise = R1 <$> gpeekSum tag (Proxy :: Proxy (n + SumArity a)) where sizeL = fromInteger (natVal (Proxy :: Proxy (n + SumArity a))) {-# INLINE gpeekSum #-} instance (GStoreSize a, KnownNat n) => GStoreSizeSum n (C1 c a) where gsizeSum x _ = getSizeWith gsize x {-# INLINE gsizeSum #-} instance (GStorePoke a, KnownNat n) => GStorePokeSum n (C1 c a) where gpokeSum x _ = do pokeStorable (fromInteger (natVal (Proxy :: Proxy n)) :: Word8) gpoke x {-# INLINE gpokeSum #-} instance (GStorePeek a, KnownNat n) => GStorePeekSum n (C1 c a) where gpeekSum tag _ | tag == cur = gpeek | tag > cur = peekException "Sum tag invalid" | otherwise = peekException "Error in implementation of Store Generics" where cur = fromInteger (natVal (Proxy :: Proxy n)) {-# INLINE gpeekSum #-} store-0.7.18/test/Spec.hs0000644000000000000000000000005414233045224013334 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} store-0.7.18/test/Data/Store/UntrustedSpec.hs0000644000000000000000000001525714233045224017232 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Tests for untrusted data. module Data.Store.UntrustedSpec where import Test.Hspec spec :: Spec spec = return () {- Untrusted data spec is disabled for now. See #122 / #123 for details import Data.Bifunctor import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.Int import Data.IntMap (IntMap) import qualified Data.IntMap as IM import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Monoid import Data.Proxy import qualified Data.Sequence as Seq import Data.Store import Data.Store.Internal import Data.String import Data.Text (Text) import qualified Data.Vector as V -- | Test suite. actualSpec :: Spec actualSpec = describe "Untrusted input throws error" (do describe "Array-like length prefixes" (do let sample :: IsString s => s sample = "abc" list :: [Int] list = [1, 2, 3] it "ByteString" (shouldBeRightWrong huge (sample :: ByteString)) it "Lazy ByteString" (shouldBeRightWrong huge (sample :: L.ByteString)) it "Text" (shouldBeRightWrong huge (sample :: Text)) it "String" (shouldBeRightWrong huge (sample :: String)) it "Vector Int" (shouldBeRightWrong huge (V.fromList list)) it "Vector Char" (shouldBeRightWrong huge (V.fromList (sample :: [Char]))) it "Vector unit" (shouldBeRightWrong huge (V.fromList (replicate 1000 ()))) it "Seq Int" (shouldBeRightWrong huge (Seq.fromList (sample :: [Char])))) describe "Maps are consistent" (do it "Map Int Int: with duplicates" (shouldBeFail (DuplicatedMap (M.fromList [(1, 2), (4, 5)] :: Map Int Int)) (Proxy :: Proxy (Map Int Int))) it "Map Int Int: wrong order" (shouldBeFail (ReversedMap (M.fromList [(1, 2), (4, 5)] :: Map Int Int)) (Proxy :: Proxy (Map Int Int))) it "IntMap Int Int: with duplicates" (shouldBeFail (DuplicatedIntMap (IM.fromList [(1, 2), (4, 5)] :: IntMap Int)) (Proxy :: Proxy (IntMap Int))) it "IntMap Int Int: wrong order" (shouldBeFail (ReversedIntMap (IM.fromList [(1, 2), (4, 5)] :: IntMap Int)) (Proxy :: Proxy (IntMap Int)))) describe "Constructor tags" (do it "Invalid constructor tag" (shouldBe (first (const ()) (decode "\2" :: Either PeekException (Maybe ()))) (Left ())) it "Missing slots" (shouldBe (first (const ()) (decode "\1" :: Either PeekException (Maybe Char))) (Left ())))) huge :: Int64 huge = 2^(62::Int) -- | Check decode.encode==id and then check decode.badencode=>error. shouldBeRightWrong :: forall i. (Store i, Eq i, Show i) => Int64 -> i -> IO () shouldBeRightWrong len input = do shouldBe (decode (encode input) :: Either PeekException i) (Right input) shouldBe (first (const ()) (decode (encodeWrongPrefix len input) :: Either PeekException i)) (Left ()) -- | Check decode.encode==id and then check decode.badencode=>error. shouldBeFail :: forall o i. (Store i, Eq o, Show o, Store o) => i -> Proxy o -> IO () shouldBeFail input _ = shouldBe (first (const ()) (decode (encode input) :: Either PeekException o)) (Left ()) -- | Encode a thing with the wrong length prefix. encodeWrongPrefix :: Store thing => Int64 -> thing -> ByteString encodeWrongPrefix len thing = encode len <> encodeThingNoPrefix thing -- | Encode the thing and drop the length prefix. encodeThingNoPrefix :: Store thing => thing -> ByteString encodeThingNoPrefix = S.drop (S.length (encode (1 :: Int64))) . encode -------------------------------------------------------------------------------- -- Map variants newtype ReversedIntMap = ReversedIntMap (IntMap Int) deriving (Show, Eq) instance Store ReversedIntMap where poke (ReversedIntMap m) = do poke markMapPokedInAscendingOrder poke (reverse (IM.toList m)) peek = error "ReversedIntMap.peek" size = VarSize (\(ReversedIntMap m) -> getSize m) newtype DuplicatedIntMap = DuplicatedIntMap (IntMap Int) deriving (Show, Eq) instance Store DuplicatedIntMap where poke (DuplicatedIntMap m) = do poke markMapPokedInAscendingOrder poke (let xs = IM.toList m in take (length xs) (cycle (take 1 xs))) peek = error "DuplicatedIntMap.peek" size = VarSize (\(DuplicatedIntMap m) -> getSize m) newtype ReversedMap = ReversedMap (Map Int Int) deriving (Show, Eq) instance Store ReversedMap where poke (ReversedMap m) = do poke markMapPokedInAscendingOrder poke (reverse (M.toList m)) peek = error "ReversedMap.peek" size = VarSize (\(ReversedMap m) -> getSize m) newtype DuplicatedMap = DuplicatedMap (Map Int Int) deriving (Show, Eq) instance Store DuplicatedMap where poke (DuplicatedMap m) = do poke markMapPokedInAscendingOrder poke (let xs = M.toList m in take (length xs) (cycle (take 1 xs))) peek = error "DuplicatedMap.peek" size = VarSize (\(DuplicatedMap m) -> getSize m) -} store-0.7.18/test/Data/StoreSpec.hs0000644000000000000000000004531214507702646015244 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MonoLocalBinds #-} module Data.StoreSpec where import Control.Applicative import Control.Exception (evaluate) import Control.Monad (unless) import Control.Monad.Fail (MonadFail) import qualified Data.Array.Unboxed as A import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Short as SBS import Data.Complex (Complex(..)) import Data.Containers (mapFromList, setFromList) import Data.Fixed (Pico) import Data.Generics (listify) import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) import Data.Hashable (Hashable) import Data.Int import Data.IntMap (IntMap) import Data.IntSet (IntSet) import qualified Data.List.NonEmpty as NE import Data.Map (Map) import Data.Monoid import Data.Proxy (Proxy(..)) import Data.Sequence (Seq) import Data.Sequences (fromList) import Data.Set (Set) import Data.Store import Data.Store.Internal import Data.Store.TH import Data.Store.TH.Internal import Data.Store.TypeHash import Data.StoreSpec.TH import Data.Text (Text) import qualified Data.Text as T import qualified Data.Time as Time import qualified Data.Time.Clock.TAI as Time import Data.Typeable (Typeable) import qualified Data.Vector as V import qualified Data.Vector.Primitive as PV import qualified Data.Vector.Storable as SV import qualified Data.Vector.Unboxed as UV import Data.Word import Foreign.C.Types import Foreign.Ptr import Foreign.Storable (Storable, sizeOf) import GHC.Fingerprint.Type (Fingerprint(..)) import GHC.Generics import GHC.Real (Ratio(..)) #if MIN_VERSION_base(4,15,0) import GHC.RTS.Flags (IoSubSystem(..)) #endif import Language.Haskell.TH import Language.Haskell.TH.Syntax import Network.Socket import Numeric.Natural (Natural) import Prelude import System.Clock (TimeSpec(..)) import System.Posix.Types import Test.Hspec hiding (runIO) import Test.SmallCheck.Series import TH.Utilities (unAppsT) #if !MIN_VERSION_primitive(0,7,0) import Data.Primitive.Types (Addr) #endif #if MIN_VERSION_time(1,8,0) import qualified Data.Time.Clock.System as Time #endif #if MIN_VERSION_time(1,9,0) import qualified Data.Time.Format.ISO8601 as Time #endif #if MIN_VERSION_time(1,11,0) import qualified Data.Time.Calendar.Quarter as Time import qualified Data.Time.Calendar.WeekDate as Time #endif #if !MIN_VERSION_smallcheck(1,2,0) import Data.Void (Void) #endif ------------------------------------------------------------------------ -- Instances for base types addMinAndMaxBounds :: forall a. (Bounded a, Eq a) => [a] -> [a] addMinAndMaxBounds xs = (if (minBound :: a) `notElem` xs then [minBound] else []) ++ (if (maxBound :: a) `notElem` xs && (maxBound :: a) /= minBound then maxBound : xs else xs) $(mkManyHasTypeHash [ [t| Int32 |] ]) -- Serial instances for (Num a, Bounded a) types. Only really -- appropriate for the use here. #if !MIN_VERSION_network(3,1,2) instance Bounded PortNumber where minBound = 0 maxBound = 65535 #endif $(do let ns = [ ''PortNumber #if !MIN_VERSION_smallcheck(1,2,0) , ''CWchar, ''CUShort, ''CULong, ''CULLong, ''CIntMax , ''CUIntMax, ''CPtrdiff, ''CSChar, ''CShort, ''CUInt, ''CLLong , ''CLong, ''CInt, ''CChar #endif , ''CSsize, ''CPid , ''COff, ''CMode, ''CIno, ''CDev #if !MIN_VERSION_smallcheck(1,1,4) , ''Word8, ''Word16, ''Word32, ''Word64 , ''Int8, ''Int16, ''Int32, ''Int64 #endif #if !MIN_VERSION_smallcheck(1,1,3) , ''Word #endif #if MIN_VERSION_base(4,10,0) #if !MIN_VERSION_smallcheck(1,2,0) , ''CBool #endif , ''CClockId, ''CKey, ''CId , ''CBlkSize, ''CFsBlkCnt, ''CFsFilCnt, ''CBlkCnt #endif #if MIN_VERSION_base(4,14,0) , ''CSocklen, ''CNfds #endif #ifndef mingw32_HOST_OS , ''CUid, ''CTcflag, ''CRLim, ''CNlink, ''CGid #endif ] f n = [d| instance Monad m => Serial m $(conT n) where series = generate (\_ -> addMinAndMaxBounds [0, 1]) |] concat <$> mapM f ns) -- Serial instances for (Num a) types. Only really appropriate for the -- use here. $(do let ns = #if !MIN_VERSION_smallcheck(1,2,0) [ ''CUSeconds, ''CClock, ''CTime, ''CUChar, ''CSize, ''CSigAtomic , ''CSUSeconds, ''CFloat, ''CDouble ] ++ #endif #if !MIN_VERSION_smallcheck(1,1,3) [ ''Natural ] ++ #endif #ifndef mingw32_HOST_OS [ ''CSpeed, ''CCc ] ++ #endif [] f n = [d| instance Monad m => Serial m $(conT n) where series = generate (\_ -> [0, 1]) |] concat <$> mapM f ns) -- Serial instances for Primitive vectors $(do tys <- getAllInstanceTypes1 ''PV.Prim let f ty = [d| instance (Serial m $(return ty), Monad m) => Serial m (PV.Vector $(return ty)) where series = fmap PV.fromList series |] concat <$> mapM f (filter (\ty -> length (unAppsT ty) == 1) tys)) $(do let ns = [ ''Dual, ''Sum, ''Product, ''First, ''Last ] f n = [d| instance (Monad m, Serial m a) => Serial m ($(conT n) a) |] concat <$> mapM f ns) instance Monad m => Serial m Any where series = fmap Any series instance Monad m => Serial m All where series = fmap All series instance Monad m => Serial m Fingerprint where series = generate (\_ -> [Fingerprint 0 0, Fingerprint maxBound maxBound]) instance Monad m => Serial m BS.ByteString where series = fmap BS.pack series instance Monad m => Serial m LBS.ByteString where series = fmap LBS.pack series instance Monad m => Serial m SBS.ShortByteString where series = fmap SBS.pack series instance (Monad m, Serial m a, Storable a) => Serial m (SV.Vector a) where series = fmap SV.fromList series instance (Monad m, Serial m a) => Serial m (V.Vector a) where series = fmap V.fromList series instance (Monad m, Serial m k, Serial m a, Ord k) => Serial m (Map k a) where series = fmap mapFromList series instance (Monad m, Serial m a, Ord a) => Serial m (Set a) where series = fmap setFromList series instance (Monad m, Serial m a) => Serial m (IntMap a) where series = fmap mapFromList series instance Monad m => Serial m IntSet where series = fmap setFromList series instance Monad m => Serial m Text where series = fmap fromList series instance (Monad m, Serial m a) => Serial m (Seq a) where series = fmap fromList series instance (Monad m, Serial m a, UV.Unbox a) => Serial m (UV.Vector a) where series = fmap fromList series instance (Monad m, Serial m k, Serial m a, Hashable k, Eq k) => Serial m (HashMap k a) where series = fmap mapFromList series instance (Monad m, Serial m a, Hashable a, Eq a) => Serial m (HashSet a) where series = fmap setFromList series instance (Monad m, A.Ix i, Serial m i, Serial m e) => Serial m (A.Array i e) where series = seriesArray instance (Monad m, A.IArray A.UArray e, A.Ix i, Serial m i, Serial m e) => Serial m (A.UArray i e) where series = seriesArray seriesArray :: (Monad m, A.Ix i, A.IArray a e, Serial m i, Serial m e) => Series m (a i e) seriesArray = cons2 $ \bounds (NonEmpty xs) -> A.listArray bounds (take (A.rangeSize bounds) (cycle xs)) instance Monad m => Serial m Time.Day where series = Time.ModifiedJulianDay <$> series instance Monad m => Serial m Time.DiffTime where series = Time.picosecondsToDiffTime <$> series instance Monad m => Serial m Time.NominalDiffTime where series = (realToFrac :: Integer -> Time.NominalDiffTime) <$> series instance Monad m => Serial m Time.UTCTime where series = uncurry Time.UTCTime <$> (series >< series) instance (Monad m, Serial m a) => Serial m (Tagged a) #if MIN_VERSION_base(4,15,0) instance Monad m => Serial m IoSubSystem where series = cons0 IoPOSIX \/ cons0 IoNative #endif #if !MIN_VERSION_smallcheck(1,2,0) instance (Monad m, Serial m a) => Serial m (Complex a) where series = uncurry (:+) <$> (series >< series) instance (Monad m, Serial m a) => Serial m (NE.NonEmpty a) instance Monad m => Serial m Void where series = generate (\_ -> []) #endif instance Monad m => Serial m TimeSpec where series = uncurry TimeSpec <$> (series >< series) -- 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 data Test = TestA Int64 Word32 | TestB Bool | TestC | TestD BS.ByteString deriving (Eq, Show, Generic) -- $(return . (:[]) =<< deriveStore [] (ConT ''Test) . dtCons =<< reifyDataType ''Test) instance Store Test instance Monad m => Serial m Test data X = X deriving (Eq, Show, Generic) instance Monad m => Serial m X instance Store X -- Datatypes with faulty instances newtype BadIdea = BadIdea Int64 instance Store BadIdea where poke (BadIdea x) = poke x peek = BadIdea <$> peek size = ConstSize 1 -- too small newtype BadIdea2 = BadIdea2 Int64 instance Store BadIdea2 where poke (BadIdea2 x) = poke x peek = BadIdea2 <$> peek size = ConstSize 12 -- too large spec :: Spec spec = do describe "Store on all monomorphic instances" $(do insts <- getAllInstanceTypes1 ''Store omitTys0 <- sequence $ #if !MIN_VERSION_primitive(0,7,0) [t| Addr |] : #endif [ [t| CUIntPtr |] , [t| CIntPtr |] , [t| IntPtr |] , [t| WordPtr |] , [t| TypeHash |] , [t| Fd |] , [t| NameFlavour |] #if MIN_VERSION_base(4,10,0) , [t| CTimer |] #endif -- Assume the TH generated instances for Time work, to avoid defining -- Serial instances. Also some lack Show / Eq. , [t| Time.AbsoluteTime |] , [t| Time.Day |] , [t| Time.LocalTime |] , [t| Time.TimeOfDay |] , [t| Time.TimeZone |] , [t| Time.UTCTime |] , [t| Time.UniversalTime |] , [t| Time.ZonedTime |] , [t| Time.TimeLocale |] #if MIN_VERSION_time(1,8,0) , [t| Time.SystemTime |] #endif #if MIN_VERSION_time(1,9,0) , [t| Time.FormatExtension |] , [t| Time.CalendarDiffDays |] , [t| Time.CalendarDiffTime |] #endif #if MIN_VERSION_time(1,11,0) , [t| Time.DayOfWeek |] , [t| Time.FirstWeekType |] , [t| Time.Quarter |] , [t| Time.QuarterOfYear |] #endif ] omitTys <- (omitTys0 ++) <$> mapM (\ty -> [t| PV.Vector $(pure ty) |]) omitTys0 let f ty = isMonoType ty && ty `notElem` omitTys && null (listify isThName ty) filtered = filter f insts -- Roundtrip testing of TH instances is disabled - see issue #150 isThName n = nameModule n == Just "Language.Haskell.TH.Syntax" smallcheckManyStore verbose 2 $ map return filtered) it "Store on non-numeric Float/Double values" $ do let testNonNumeric :: forall a m. (RealFloat a, Eq a, Show a, Typeable a, Store a, Monad m, MonadFail m) => Proxy a -> m () testNonNumeric _proxy = do assertRoundtrip verbose ((1/0) :: a) assertRoundtrip verbose ((-1/0) :: a) -- -0 == 0, so we check if the infinity sign is the same case decode (encode ((-0) :: a)) of Right (x :: a) -> unless (-1/0 == 1/x) (fail "Could not roundtrip negative 0") _ -> fail "Could not roundtrip negative 0" assertRoundtrip verbose ((-0) :: a) -- 0/0 /= 0/0, so we check for NaN explicitly case decode (encode ((0/0) :: a)) of Right (x :: a) -> unless (isNaN x) (fail "Could not roundtrip NaN") _ -> fail "Could not roundtrip NaN" testNonNumeric (Proxy :: Proxy Double) testNonNumeric (Proxy :: Proxy Float) testNonNumeric (Proxy :: Proxy CDouble) testNonNumeric (Proxy :: Proxy CFloat) (return () :: IO ()) describe "Store on all custom generic instances" $(smallcheckManyStore verbose 2 [ [t| Test |] , [t| X |] ]) describe "Manually listed polymorphic store instances" $(smallcheckManyStore verbose 4 [ [t| SV.Vector Int8 |] , [t| V.Vector Int8 |] , [t| SerialRatio Int8 |] , [t| Complex Int8 |] , [t| Dual Int8 |] , [t| Sum Int8 |] , [t| Product Int8 |] , [t| First Int8 |] , [t| Last Int8 |] , [t| Maybe Int8 |] , [t| Either Int8 Int8 |] , [t| SV.Vector Int64 |] , [t| V.Vector Int64 |] , [t| SerialRatio Int64 |] , [t| Complex Int64 |] , [t| Dual Int64 |] , [t| Sum Int64 |] , [t| Product Int64 |] , [t| First Int64 |] , [t| Last Int64 |] , [t| Maybe Int64 |] , [t| Either Int64 Int64 |] , [t| (Int8, Int16) |] , [t| (Int8, Int16, Bool) |] , [t| (Bool, (), (), ()) |] , [t| (Bool, (), Int8, ()) |] -- Container-ey types , [t| [Int8] |] , [t| [Int64] |] , [t| Seq Int8 |] , [t| Seq Int64 |] , [t| Set Int8 |] , [t| Set Int64 |] , [t| IntMap Int8 |] , [t| IntMap Int64 |] , [t| Map Int8 Int8 |] , [t| Map Int64 Int64 |] , [t| HashMap Int8 Int8 |] , [t| HashMap Int64 Int64 |] , [t| HashSet Int8 |] , [t| HashSet Int64 |] , [t| NE.NonEmpty Int8 |] , [t| NE.NonEmpty Int64 |] , [t| Tagged Int32 |] , [t| A.Array (Int, Integer) Integer |] , [t| A.UArray Char Bool |] ]) it "Slices roundtrip" $ do assertRoundtrip False $ T.drop 3 $ T.take 3 "Hello world!" assertRoundtrip False $ BS.drop 3 $ BS.take 3 "Hello world!" assertRoundtrip False $ SV.drop 3 $ SV.take 3 (SV.fromList [1..10] :: SV.Vector Int32) assertRoundtrip False $ UV.drop 3 $ UV.take 3 (UV.fromList [1..10] :: UV.Vector Word8) (return () :: IO ()) it "StaticSize roundtrips" $ do let x :: StaticSize 17 BS.ByteString x = toStaticSizeEx (BS.replicate 17 255) unless (checkRoundtrip False x) $ (fail "Failed to roundtrip StaticSize ByteString" :: IO ()) it "Size of generic instance for single fieldless constructor is 0" $ do case size :: Size X of ConstSize 0 -> (return () :: IO ()) _ -> fail "Empty datatype takes up space" it "Printing out polymorphic store instances" $ do putStrLn "" putStrLn "Not really a test - printing out known polymorphic store instances (which should all be tested above)" putStrLn "" mapM_ putStrLn $(do insts <- getAllInstanceTypes1 ''Store lift $ map pprint $ filter (not . isMonoType) insts) it "Faulty implementations of size lead to PokeExceptions" $ do evaluate (encode (BadIdea 0)) `shouldThrow` isPokeException evaluate (encode (BadIdea2 0)) `shouldThrow` isPokeException it "Avoids reading data with a negative size" $ do let bs = encode (SV.fromList [1..10::Int]) bs' = BS.concat [encode (-1 :: Int) , BS.drop (sizeOf (10 :: Int)) bs ] evaluate (decodeEx bs' :: SV.Vector Int) `shouldThrow` isNegativeBytesException it "Avoids overflow in bounds checks" $ do let bs = encode ("some random bytestring" :: BS.ByteString) bs' = BS.concat [encode (maxBound :: Int) , BS.drop (sizeOf (10 :: Int)) bs ] evaluate (decodeEx bs' :: BS.ByteString) `shouldThrow` isTooManyBytesException it "Handles unaligned access" $ do assertRoundtrip verbose (250 :: Word8, 40918 :: Word16, 120471416 :: Word32) assertRoundtrip verbose (250 :: Word8, 10.1 :: Float, 8697.65 :: Double) (return () :: IO ()) it "Expects the right marker when deserializing ordered maps (#97)" $ do let m = mapFromList [(1, ()), (2, ()), (3, ())] :: HashMap Int () bs = encode m (decodeEx bs :: HashMap Int ()) `shouldBe` m evaluate (decodeEx bs :: Map Int ()) `shouldThrow` isUnexpectedMarkerException evaluate (decodeEx bs :: IntMap ()) `shouldThrow` isUnexpectedMarkerException it "Expects decode of negative integer as a natural to throw PeekException" $ do evaluate (decodeEx (encode ((-5) :: Integer)) :: Natural) `shouldThrow` isNegativeNaturalException isPokeException :: Test.Hspec.Selector PokeException isPokeException = const True isNegativeBytesException :: Test.Hspec.Selector PeekException isNegativeBytesException (PeekException _ t) = "Attempted to read negative number of bytes" `T.isPrefixOf` t isTooManyBytesException :: Test.Hspec.Selector PeekException isTooManyBytesException (PeekException _ t) = "Attempted to read too many bytes" `T.isPrefixOf` t isUnexpectedMarkerException :: Test.Hspec.Selector PeekException isUnexpectedMarkerException (PeekException _ t) = "Expected marker for ascending Map / IntMap: " `T.isPrefixOf` t isNegativeNaturalException :: Test.Hspec.Selector PeekException isNegativeNaturalException (PeekException _ t) = "Encountered negative integer when expecting a Natural" `T.isPrefixOf` t store-0.7.18/test/Data/StoreSpec/TH.hs0000644000000000000000000000034414233045224015537 0ustar0000000000000000{-# LANGUAGE CPP #-} -- Just exists due to TH stage restriction... The actual testing TH code -- is in "Data.Store.TH". module Data.StoreSpec.TH where verbose :: Bool verbose = #if VERBOSE_TEST True #else False #endif store-0.7.18/test/System/IO/ByteBufferSpec.hs0000644000000000000000000000441714233045224017114 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} module System.IO.ByteBufferSpec where import Control.Exception import qualified Data.ByteString as BS import Data.Typeable (Typeable) import qualified System.IO.ByteBuffer as BB import Test.Hspec data MyException = MyException deriving (Eq, Show, Typeable) instance Exception MyException spec :: Spec spec = describe "ByteBuffer" $ do it "can grow to store a value and return it." $ BB.with (Just 0) $ \ bb -> do let bs = "some bytestring" BB.copyByteString bb bs bs' <- BB.consume bb (BS.length bs) bs' `shouldBe` Right bs bbIsEmpty bb it "should request more input when needed." $ BB.with (Just 0) $ \ bb -> do let bs = "some bytestring" BB.copyByteString bb bs bs' <- BB.consume bb (2 * BS.length bs) bs' `shouldBe` Left (BS.length bs) BB.copyByteString bb bs bs'' <- BB.consume bb (2 * BS.length bs) bs'' `shouldBe` Right (BS.concat [bs, bs]) bbIsEmpty bb it "should not grow if bytes can be freed." $ let bs1 = "12345" bs2 = "67810" -- what about nine? 7 8 9! in BB.with (Just $ BS.length bs1) $ \ bb -> do BB.copyByteString bb bs1 bs1' <- BB.consume bb (BS.length bs1) BB.copyByteString bb bs2 bs2' <- BB.consume bb (BS.length bs2) bs1' `shouldBe` Right bs1 bs2' `shouldBe` Right bs2 bbSize <- BB.totalSize bb bbSize `shouldBe` BS.length bs1 bbIsEmpty bb it "should raise a ByteBufferException when used after freed" $ BB.with Nothing $ \bb -> do BB.free bb BB.totalSize bb `shouldThrow` \(BB.ByteBufferException loc e) -> loc == "free" && e == "ByteBuffer has explicitly been freed and is no longer valid." it "should raise a ByteBufferException after a failed operation" $ BB.with Nothing $ \bb -> do BB.copyByteString bb (throw MyException) `shouldThrow` (\MyException -> True) BB.consume bb 10 `shouldThrow` \(BB.ByteBufferException loc e) -> loc == "copyByteString" && e == show MyException bbIsEmpty :: BB.ByteBuffer -> Expectation bbIsEmpty bb = BB.isEmpty bb >>= (`shouldBe` True) store-0.7.18/test/Allocations.hs0000644000000000000000000000456714233045224014727 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} -- | Weigh Store's operations. module Main where import Control.DeepSeq import qualified Data.IntMap.Strict as IntMap import qualified Data.IntSet as IntSet import qualified Data.Serialize as Cereal import qualified Data.Set as Set import qualified Data.Map.Strict as Map import qualified Data.Store as Store import qualified Data.Vector as Boxed import qualified Data.Vector.Serialize () import qualified Data.Vector.Storable as Storable import Text.Printf import Weigh -- | Main entry point. main :: IO () main = mainWith weighing -- | Weigh weighing with Store vs Cereal. weighing :: Weigh () weighing = do fortype "[Int]" (\n -> replicate n 0 :: [Int]) fortype "Boxed Vector Int" (\n -> Boxed.replicate n 0 :: Boxed.Vector Int) fortype "Storable Vector Int" (\n -> Storable.replicate n 0 :: Storable.Vector Int) fortype "Set Int" (Set.fromDistinctAscList . ints) fortype "IntSet" (IntSet.fromDistinctAscList . ints) fortype "Map Int Int" (Map.fromDistinctAscList . intpairs) fortype "IntMap Int" (IntMap.fromDistinctAscList . intpairs) where fortype label make = scale (\(n,nstr) -> do let title :: String -> String title for = printf "%12s %-20s %s" nstr (label :: String) for encodeDecode en de = (return . (`asTypeOf` make n) . de . force . en . make) n action (title "Allocate") (return (make n)) action (title "Encode: Store") (return (Store.encode (force (make n)))) action (title "Encode: Cereal") (return (Cereal.encode (force (make n)))) action (title "Encode/Decode: Store") (encodeDecode Store.encode Store.decodeEx) action (title "Encode/Decode: Cereal") (encodeDecode Cereal.encode (fromRight . Cereal.decode))) scale f = mapM_ f (map (\x -> (x,commas x)) [1000000,2000000,10000000]) ints n = [1..n] :: [Int] intpairs = map (\x -> (x, x)) . ints fromRight = either (error "Left") id store-0.7.18/bench/Bench.hs0000644000000000000000000002243514233045224013570 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} #if !MIN_VERSION_base(4,8,0) {-# LANGUAGE DeriveDataTypeable #-} import Control.Applicative ((<$>), (<*>), (*>)) #endif import Control.DeepSeq import Criterion.Main import qualified Data.ByteString as BS import Data.Int import qualified Data.IntMap.Strict as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Data.Store import Data.Typeable import qualified Data.Vector as V import qualified Data.Vector.Storable as SV import Data.Word import GHC.Generics #if COMPARISON_BENCH import qualified Data.Binary as Binary import qualified Data.Serialize as Cereal import qualified Data.ByteString.Lazy as BL import Data.Vector.Serialize () #endif data SomeData = SomeData !Int64 !Word8 !Double deriving (Eq, Show, Generic, Typeable) instance NFData SomeData where rnf x = x `seq` () instance Store SomeData #if COMPARISON_BENCH instance Cereal.Serialize SomeData instance Binary.Binary SomeData #endif main :: IO () main = do #if SMALL_BENCH let is = 0::Int sds = SomeData 1 1 1 smallprods = (SmallProduct 0 1 2 3) smallmanualprods = (SmallProductManual 0 1 2 3) sss = [SS1 1, SS2 2, SS3 3, SS4 4] ssms = [SSM1 1, SSM2 2, SSM3 3, SSM4 4] nestedTuples = ((1,2),(3,4)) :: ((Int,Int),(Int,Int)) #else let is = V.enumFromTo 1 100 :: V.Vector Int sds = (\i -> SomeData i (fromIntegral i) (fromIntegral i)) <$> V.enumFromTo 1 100 smallprods = (\ i -> SmallProduct i (i+1) (i+2) (i+3)) <$> V.enumFromTo 1 100 smallmanualprods = (\ i -> SmallProductManual i (i+1) (i+2) (i+3)) <$> V.enumFromTo 1 100 sss = (\i -> case i `mod` 4 of 0 -> SS1 (fromIntegral i) 1 -> SS2 (fromIntegral i) 2 -> SS3 (fromIntegral i) 3 -> SS4 (fromIntegral i) _ -> error "This does not compute." ) <$> V.enumFromTo 1 (100 :: Int) ssms = (\i -> case i `mod` 4 of 0 -> SSM1 (fromIntegral i) 1 -> SSM2 (fromIntegral i) 2 -> SSM3 (fromIntegral i) 3 -> SSM4 (fromIntegral i) _ -> error "This does not compute." ) <$> V.enumFromTo 1 (100 :: Int) nestedTuples = (\i -> ((i,i+1),(i+2,i+3))) <$> V.enumFromTo (1::Int) 100 ints = [1..100] :: [Int] pairs = map (\x -> (x, x)) ints strings = show <$> ints intsSet = Set.fromDistinctAscList ints intSet = IntSet.fromDistinctAscList ints intsMap = Map.fromDistinctAscList pairs intMap = IntMap.fromDistinctAscList pairs stringsSet = Set.fromList strings stringsMap = Map.fromList (zip strings ints) #endif defaultMain [ bgroup "encode" [ benchEncode is #if !SMALL_BENCH , benchEncode' "1kb storable" (SV.fromList ([1..256] :: [Int32])) , benchEncode' "10kb storable" (SV.fromList ([1..(256 * 10)] :: [Int32])) , benchEncode' "1kb normal" (V.fromList ([1..256] :: [Int32])) , benchEncode' "10kb normal" (V.fromList ([1..(256 * 10)] :: [Int32])) , benchEncode intsSet , benchEncode intSet , benchEncode intsMap , benchEncode intMap , benchEncode stringsSet , benchEncode stringsMap #endif , benchEncode smallprods , benchEncode smallmanualprods , benchEncode sss , benchEncode ssms , benchEncode nestedTuples , benchEncode sds ] , bgroup "decode" [ benchDecode is #if !SMALL_BENCH , benchDecode' "1kb storable" (SV.fromList ([1..256] :: [Int32])) , benchDecode' "10kb storable" (SV.fromList ([1..(256 * 10)] :: [Int32])) , benchDecode' "1kb normal" (V.fromList ([1..256] :: [Int32])) , benchDecode' "10kb normal" (V.fromList ([1..(256 * 10)] :: [Int32])) , benchDecode intsSet , benchDecode intSet , benchDecode intsMap , benchDecode intMap , benchDecode stringsSet , benchDecode stringsMap #endif , benchDecode smallprods , benchDecode smallmanualprods , benchDecode sss , benchDecode ssms , benchDecode nestedTuples , benchDecode sds ] ] type Ctx a = ( Store a, Typeable a, NFData a #if COMPARISON_BENCH , Binary.Binary a , Cereal.Serialize a #endif ) benchEncode :: Ctx a => a -> Benchmark benchEncode = benchEncode' "" benchEncode' :: Ctx a => String -> a -> Benchmark benchEncode' msg x0 = env (return x0) $ \x -> let label = msg ++ " (" ++ show (typeOf x0) ++ ")" benchStore name = bench name (nf encode x) in #if COMPARISON_BENCH bgroup label [ benchStore "store" , bench "cereal" (nf Cereal.encode x) , bench "binary" (nf Binary.encode x) ] #else benchStore label #endif benchDecode :: Ctx a => a -> Benchmark benchDecode = benchDecode' "" benchDecode' :: forall a. Ctx a => String -> a -> Benchmark #if COMPARISON_BENCH benchDecode' prefix x0 = bgroup label [ env (return (encode x0)) $ \x -> bench "store" (nf (decodeEx :: BS.ByteString -> a) x) , env (return (Cereal.encode x0)) $ \x -> bench "cereal" (nf ((ensureRight . Cereal.decode) :: BS.ByteString -> a) x) , env (return (Binary.encode x0)) $ \x -> bench "binary" (nf (Binary.decode :: BL.ByteString -> a) x) ] where label = prefix ++ " (" ++ show (typeOf x0) ++ ")" ensureRight (Left x) = error "left!" ensureRight (Right x) = x #else benchDecode' prefix x0 = env (return (encode x0)) $ \x -> bench (prefix ++ " (" ++ show (typeOf x0) ++ ")") (nf (decodeEx :: BS.ByteString -> a) x) #endif ------------------------------------------------------------------------ -- Serialized datatypes data SmallProduct = SmallProduct Int32 Int32 Int32 Int32 deriving (Generic, Show, Typeable) instance NFData SmallProduct instance Store SmallProduct data SmallProductManual = SmallProductManual Int32 Int32 Int32 Int32 deriving (Generic, Show, Typeable) instance NFData SmallProductManual instance Store SmallProductManual where size = ConstSize 16 peek = SmallProductManual <$> peek <*> peek <*> peek <*> peek poke (SmallProductManual a b c d) = poke a *> poke b *> poke c *> poke d data SmallSum = SS1 Int8 | SS2 Int32 | SS3 Int64 | SS4 Word32 deriving (Generic, Show, Typeable) instance NFData SmallSum instance Store SmallSum data SmallSumManual = SSM1 Int8 | SSM2 Int32 | SSM3 Int64 | SSM4 Word32 deriving (Generic, Show, Typeable) instance NFData SmallSumManual instance Store SmallSumManual where size = VarSize $ \x -> 1 + case x of SSM1{} -> 1 SSM2{} -> 4 SSM3{} -> 8 SSM4{} -> 4 peek = do tag <- peek case tag :: Word8 of 0 -> SSM1 <$> peek 1 -> SSM2 <$> peek 2 -> SSM3 <$> peek 3 -> SSM4 <$> peek _ -> fail "Invalid tag" poke (SSM1 x) = poke (0 :: Word8) >> poke x poke (SSM2 x) = poke (1 :: Word8) >> poke x poke (SSM3 x) = poke (2 :: Word8) >> poke x poke (SSM4 x) = poke (3 :: Word8) >> poke x #if COMPARISON_BENCH instance Binary.Binary SmallProduct instance Binary.Binary SmallSum instance Cereal.Serialize SmallProduct instance Cereal.Serialize SmallSum instance Binary.Binary SmallProductManual where get = SmallProductManual <$> Binary.get <*> Binary.get <*> Binary.get <*> Binary.get put (SmallProductManual a b c d) = Binary.put a *> Binary.put b *> Binary.put c *> Binary.put d instance Binary.Binary SmallSumManual where get = do tag <- Binary.get case tag :: Word8 of 0 -> SSM1 <$> Binary.get 1 -> SSM2 <$> Binary.get 2 -> SSM3 <$> Binary.get 3 -> SSM4 <$> Binary.get _ -> fail "Invalid tag" put (SSM1 x) = Binary.put (0 :: Word8) *> Binary.put x put (SSM2 x) = Binary.put (1 :: Word8) *> Binary.put x put (SSM3 x) = Binary.put (2 :: Word8) *> Binary.put x put (SSM4 x) = Binary.put (3 :: Word8) *> Binary.put x instance Cereal.Serialize SmallProductManual where get = SmallProductManual <$> Cereal.get <*> Cereal.get <*> Cereal.get <*> Cereal.get put (SmallProductManual a b c d) = Cereal.put a *> Cereal.put b *> Cereal.put c *> Cereal.put d instance Cereal.Serialize SmallSumManual where get = do tag <- Cereal.get case tag :: Word8 of 0 -> SSM1 <$> Cereal.get 1 -> SSM2 <$> Cereal.get 2 -> SSM3 <$> Cereal.get 3 -> SSM4 <$> Cereal.get _ -> fail "Invalid tag" put (SSM1 x) = Cereal.put (0 :: Word8) *> Cereal.put x put (SSM2 x) = Cereal.put (1 :: Word8) *> Cereal.put x put (SSM3 x) = Cereal.put (2 :: Word8) *> Cereal.put x put (SSM4 x) = Cereal.put (3 :: Word8) *> Cereal.put x #endif store-0.7.18/ChangeLog.md0000644000000000000000000001525114272422325013311 0ustar0000000000000000# ChangeLog ## 0.7.16 * Adds support for `vector-0.13.0.0`. See [#174][]. [#174]: https://github.com/mgsloan/store/issues/174 ## 0.7.15 * Adds support for `text >= 2`. See [#170][]. [#170]: https://github.com/mgsloan/store/issues/170 ## 0.7.14 * Fixes build with ghc-8.10 (broken in last release due to differences in TH API). See [#165][]. [#165]: https://github.com/mgsloan/store/issues/165 ## 0.7.13 * Fix build with `time >= 1.11`. See [#162][]. * Adds missing `liftTyped` method for `Lift TypeHash`. See [#163][]. [#162]: https://github.com/mgsloan/store/issues/162 [#163]: https://github.com/mgsloan/store/issues/163 ## 0.7.12 * Build with ghc-9.0.1 ## 0.7.11 * Fixes testsuite compilation with `network >= 3.1.2`. See [#159][]. ## 0.7.10 * Adds `Store` instances for all serializable datatypes exported by the `time` library. See [#158][]. [#158]: https://github.com/mgsloan/store/issues/158 ## 0.7.9 * Attempts to fix build on ghc-7.8.4. See [#157][]. [#157]: https://github.com/mgsloan/store/issues/157 ## 0.7.8 * Adds a `Store` instance for `Natural`. See [#154][]. [#154]: https://github.com/mgsloan/store/issues/154 ## 0.7.7 * Test now compiles with `smallcheck >= 1.2` and `base >= 4.14`. See [#153][]. [#153]: https://github.com/fpco/store/issues/153 ## 0.7.6 * Now only depends on `fail` / `semigroups` shim for `ghc < 8`. ## 0.7.4 * Fix for compilation with `ghc-8.10` in `0.7.3` did not use enough CPP, and so broke builds for older versions. This release fixes that. ## 0.7.3 * Fixes compilation with `ghc-8.10`, particularly `template-haskell-2.16.0.0`. See [#149][]. [#149]: https://github.com/fpco/store/issues/149 ## 0.7.2 * Fixes compilation with `vector >= 0.12.1.1` by making `deriveManyStoreUnboxVector` capable of handling more complex instance constraints. In particular, it now correctly generates instances `Store (Vector (f (g a))) => Store (Vector (Compose f g a))` and `Store (Vector (f a)) => Store (Vector (Alt f a))`. ## 0.7.1 * Fixes compilation with GHC-7.10 due to it not defining `Generic` instances for `Complex` and `Identity`. See [#142][]. * Documents some gotchas about using store vs other libraries [#142]: https://github.com/fpco/store/issues/142 ## 0.7.0 * Fixes a bug where the `Store` instances for `Identity`, `Const`, and `Complex` all have `Storable` superclasses instead of `Store. See [#143][]. [#143]: https://github.com/fpco/store/issues/143 ## 0.6.1 * Can now optionally be built with `integer-simple` instead of `integer-gmp`, via the `integer-simple` cabal flag. Note that the serialization of `Integer` with `integer-simple` differs from what is used by the GMP default. See [#147][]. [#147]: https://github.com/fpco/store/pull/147 ## 0.6.0.1 * Now builds with GHC-7.10 - compatibility was broken in 0.6.0 due to the fix for GHC-8.8. See [#146][https://github.com/fpco/store/issues/146]. ## 0.6.0 * Now builds with GHC-8.8. This is a major version bump because MonadFail constraints were added to some functions, which is potentially a breaking change. ## 0.5.1.2 * Fixes compilation with GHC < 8.0. See [#142](https://github.com/fpco/store/issues/142). ## 0.5.1.1 * Update to the instances for generics, to improve error messages for sum types with more than 255 constructors. See [#141](https://github.com/fpco/store/issues/141) ## 0.5.1.0 * Update to TH to support sum types with more than 62 constructors. * Uses TH to derive Either instance, so that it can sometimes have ConstSize #119. ## 0.5.0.1 * Updates to test-suite enabling `store` to build with newer dependencies. ## 0.5.0 * `Data.Store.Streaming` moved to a separate package, `store-streaming`. ## 0.4.3.2 * Buildable with GHC 8.2 * Fix to haddock formatting of Data.Store.TH code example ## 0.4.3.1 * Fixed compilation on GHC 7.8 ## 0.4.3 * Less aggressive inlining, resulting in faster compilation / simplifier not running out of ticks ## 0.4.2 * Fixed testsuite ## 0.4.1 * Breaking change in the encoding of Map / Set / IntMap / IntSet, to use ascending key order. Attempting to decode data written by prior versions of store (and vice versa) will almost always fail with a decent error message. If you're unlucky enough to have a collision in the data with a random Word32 magic number, then the error may not be so clear, or in extremely rare cases, successfully decode, yielding incorrect results. See [#97](https://github.com/fpco/store/issues/97) and [#101](https://github.com/fpco/store/pull/101). * Performance improvement of the 'Peek' monad, by introducing more strictness. This required a change to the internal API. * API and behavior of 'Data.Store.Version' changed. Previously, it would check the version tag after decoding the contents. It now also stores a magic Word32 tag at the beginning, so that it fails more gracefully when decoding input that lacks encoded version info. ## 0.4.0 Deprecated in favor of 0.4.1 ## 0.3.1 * Fix to derivation of primitive vectors, only relevant when built with primitive-0.6.2.0 or later * Removes INLINE pragmas on the generic default methods. This dramatically improves compilation time on recent GHC versions. See [#91](https://github.com/fpco/store/issues/91). * Adds `instance Contravariant Size` ## 0.3 * Uses store-core-0.3.*, which has support for alignment sensitive architectures. * Adds support for streaming decode from file descriptor, not supported on windows. As part of this addition, the API for "Data.Store.Streaming" has changed. ## 0.2.1.2 * Fixes a bug that could could result in attempting to malloc a negative number of bytes when reading corrupted data. ## 0.2.1.1 * Fixes a bug that could result in segfaults when reading corrupted data. ## 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: * Core functionality split into `store-core` package Breaking changes: * `combineSize'` renamed to `combineSizeWith` * Streaming support now prefixes each Message with a magic number, intended to detect mis-alignment of data frames. This is worth the overhead, because otherwise serialization errors could be more catastrophic - interpretting some bytes as a length tag and attempting to consume many bytes from the source. Other enhancements: * [weigh](https://github.com/fpco/weigh) based allocations benchmark. * Addition of `Array` / `UArray` instances * Streaming support now has checks for over/undershooting buffer Bug fixes: ## 0.1.0.0 * First public release store-0.7.18/README.md0000644000000000000000000000615314233045616012421 0ustar0000000000000000# store The 'store' package provides efficient binary serialization. There are a couple features that particularly distinguish it from most prior Haskell serialization libraries: * Its primary goal is speed. By default, direct machine representations are used for things like numeric values (`Int`, `Double`, `Word32`, etc) and buffers (`Text`, `ByteString`, `Vector`, etc). This means that much of serialization uses the equivalent of `memcpy`. We have plans for supporting architecture independent serialization - see [#36](https://github.com/fpco/store/issues/36) and [#31](https://github.com/fpco/store/issues/31). This plan makes little endian the default, so that the most common endianness has no overhead. - Another way that the serialization behavior can vary is if integer-simple is used instead of GHC's default of using GMP. `Integer` serialized with the `integer-simple` flag enabled are not compatible with those serialized without the flag enabled. * Instead of implementing lazy serialization / deserialization involving multiple input / output buffers, `peek` and `poke` always work with a single buffer. This buffer is allocated by asking the value for its size before encoding. This simplifies the encoding logic, and allows for highly optimized tight loops. * `store` can optimize size computations by knowing when some types always use the same number of bytes. This allows us to compute the byte size of a `Vector Int32` by just doing `length v * 4`. It also features: * Optimized serialization instances for many types from base, vector, bytestring, text, containers, time, template-haskell, and more. * TH and GHC Generics based generation of Store instances for datatypes. * TH generation of testcases. * Utilities for streaming encoding / decoding of Store encoded messages, via the `store-streaming` package. ## Gotchas Store is best used for communication between trusted processes and local caches. It can certainly be used for other purposes, but the builtin set of instances have some gotchas to be aware of: * Store's builtin instances serialize in a format which depends on machine endianness. * Store's builtin instances trust the data when deserializing. For example, the deserialization of `Vector` will read the vector's length from the first 8 bytes. It will then allocate enough memory to store all the elements. Malicious or malformed input could cause allocation of large amounts of memory. See [issue #122][]. * Serialization may vary based on the version of datatypes. For example, `Text` serialized from `text < 2` will not be compatible with `Text` from `text >= 2`, because the internal representation switched from UTF-16 to UTF-8. [issue #122]: https://github.com/fpco/store/issues/122 ## Blog posts * [Initial release announcement](https://www.fpcomplete.com/blog/2016/05/store-package) * [Benchmarks of the prototype](https://www.fpcomplete.com/blog/2016/03/efficient-binary-serialization) * [New 'weigh' allocation benchmark package](https://www.fpcomplete.com/blog/2016/05/weigh-package), created particularly to aid optimizing `store`. store-0.7.18/LICENSE0000644000000000000000000000206614233045224012141 0ustar0000000000000000The MIT License (MIT) Copyright (c) 2016 FP Complete Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. store-0.7.18/Setup.hs0000644000000000000000000000005614233045224012565 0ustar0000000000000000import Distribution.Simple main = defaultMain store-0.7.18/store.cabal0000644000000000000000000001773714510034421013262 0ustar0000000000000000cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack name: store version: 0.7.18 synopsis: Fast binary serialization category: Serialization, Data homepage: https://github.com/mgsloan/store#readme bug-reports: https://github.com/mgsloan/store/issues maintainer: Michael Sloan copyright: 2016 FP Complete license: MIT license-file: LICENSE build-type: Simple tested-with: GHC==9.4.5 , GHC==9.2.8 , GHC==9.0.2 , GHC==8.10.7 , GHC==8.8.4 , GHC==8.6.5 , GHC==8.4.4 extra-source-files: ChangeLog.md README.md source-repository head type: git location: https://github.com/mgsloan/store flag comparison-bench manual: True default: False flag integer-simple description: Use the [simple integer library](http://hackage.haskell.org/package/integer-simple) instead of [integer-gmp](http://hackage.haskell.org/package/integer-gmp) manual: False default: False flag small-bench manual: True default: False library exposed-modules: Data.Store Data.Store.Internal Data.Store.TH Data.Store.TH.Internal Data.Store.TypeHash Data.Store.TypeHash.Internal Data.Store.Version System.IO.ByteBuffer other-modules: Data.Store.Impl hs-source-dirs: src ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 build-depends: array >=0.5.0.0 , async >=2.0.2 , base >=4.7 && <5 , base-orphans >=0.4.3 , base64-bytestring >=0.1.1 , bifunctors >=4.0 , bytestring >=0.10.4.0 , containers >=0.5.5.1 , contravariant >=1.3 , cryptohash-sha1 >=0.11.6 , deepseq >=1.3.0.2 , directory >=1.2 , filepath >=1.3 , free >=4.11 , ghc-prim >=0.3.1.0 , hashable >=1.2.3.1 , hspec >=2.1.2 , hspec-smallcheck >=0.3.0 , lifted-base >=0.2.3.3 , monad-control >=0.3.3.0 , mono-traversable >=0.7.0 , nats >=1 , network >=2.6.0.2 , primitive >=0.6 , resourcet >=1.1.3.3 , safe >=0.3.8 , smallcheck >=1.1.1 , store-core ==0.4.* , syb >=0.4.4 , template-haskell >=2.9.0.0 , text >=1.2.0.4 , th-lift >=0.7.1 , th-lift-instances >=0.1.4 , th-orphans >=0.13.2 , th-reify-many >=0.1.6 , th-utilities >=0.2 , time >=1.5 , transformers >=0.3.0.0 , unordered-containers >=0.2.5.1 , vector >=0.10.12.3 , void >=0.5.11 default-language: Haskell2010 if flag(integer-simple) build-depends: integer-simple >=0.1.1.1 else cpp-options: -DINTEGER_GMP build-depends: integer-gmp >=0.5.1.0 if impl(ghc < 8.0) build-depends: fail >=4.9 , semigroups >=0.8 test-suite store-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: Data.Store.UntrustedSpec Data.StoreSpec Data.StoreSpec.TH System.IO.ByteBufferSpec hs-source-dirs: test ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -threaded -rtsopts -with-rtsopts=-N build-tool-depends: hspec-discover:hspec-discover build-depends: array >=0.5.0.0 , async >=2.0.2 , base >=4.7 && <5 , base-orphans >=0.4.3 , base64-bytestring >=0.1.1 , bifunctors >=4.0 , bytestring >=0.10.4.0 , clock >=0.3 , containers >=0.5.5.1 , contravariant >=1.3 , cryptohash-sha1 >=0.11.6 , deepseq >=1.3.0.2 , directory >=1.2 , filepath >=1.3 , free >=4.11 , ghc-prim >=0.3.1.0 , hashable >=1.2.3.1 , hspec >=2.1.2 , hspec-smallcheck >=0.3.0 , lifted-base >=0.2.3.3 , monad-control >=0.3.3.0 , mono-traversable >=0.7.0 , nats >=1 , network >=2.6.0.2 , primitive >=0.6 , resourcet >=1.1.3.3 , safe >=0.3.8 , smallcheck >=1.1.1 , store , store-core ==0.4.* , syb >=0.4.4 , template-haskell >=2.9.0.0 , text >=1.2.0.4 , th-lift >=0.7.1 , th-lift-instances >=0.1.4 , th-orphans >=0.13.2 , th-reify-many >=0.1.6 , th-utilities >=0.2 , time >=1.5 , transformers >=0.3.0.0 , unordered-containers >=0.2.5.1 , vector >=0.10.12.3 , void >=0.5.11 default-language: Haskell2010 if flag(integer-simple) build-depends: integer-simple >=0.1.1.1 else cpp-options: -DINTEGER_GMP build-depends: integer-gmp >=0.5.1.0 if impl(ghc < 8.0) build-depends: fail >=4.9 , semigroups >=0.8 benchmark store-bench type: exitcode-stdio-1.0 main-is: Bench.hs other-modules: Paths_store hs-source-dirs: bench ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -threaded -rtsopts -with-rtsopts=-N1 -with-rtsopts=-s -with-rtsopts=-qg build-depends: array >=0.5.0.0 , async >=2.0.2 , base >=4.7 && <5 , base-orphans >=0.4.3 , base64-bytestring >=0.1.1 , bifunctors >=4.0 , bytestring >=0.10.4.0 , containers >=0.5.5.1 , contravariant >=1.3 , criterion , cryptohash-sha1 >=0.11.6 , deepseq >=1.3.0.2 , directory >=1.2 , filepath >=1.3 , free >=4.11 , ghc-prim >=0.3.1.0 , hashable >=1.2.3.1 , hspec >=2.1.2 , hspec-smallcheck >=0.3.0 , lifted-base >=0.2.3.3 , monad-control >=0.3.3.0 , mono-traversable >=0.7.0 , nats >=1 , network >=2.6.0.2 , primitive >=0.6 , resourcet >=1.1.3.3 , safe >=0.3.8 , smallcheck >=1.1.1 , store , store-core ==0.4.* , syb >=0.4.4 , template-haskell >=2.9.0.0 , text >=1.2.0.4 , th-lift >=0.7.1 , th-lift-instances >=0.1.4 , th-orphans >=0.13.2 , th-reify-many >=0.1.6 , th-utilities >=0.2 , time >=1.5 , transformers >=0.3.0.0 , unordered-containers >=0.2.5.1 , vector >=0.10.12.3 , void >=0.5.11 default-language: Haskell2010 if flag(integer-simple) build-depends: integer-simple >=0.1.1.1 else cpp-options: -DINTEGER_GMP build-depends: integer-gmp >=0.5.1.0 if impl(ghc < 8.0) build-depends: fail >=4.9 , semigroups >=0.8 if flag(comparison-bench) cpp-options: -DCOMPARISON_BENCH build-depends: binary , cereal , cereal-vector , vector-binary-instances if flag(small-bench) cpp-options: -DSMALL_BENCH benchmark store-weigh type: exitcode-stdio-1.0 main-is: Allocations.hs hs-source-dirs: test ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T -O2 build-depends: array >=0.5.0.0 , async >=2.0.2 , base >=4.7 && <5 , base-orphans >=0.4.3 , base64-bytestring >=0.1.1 , bifunctors >=4.0 , bytestring >=0.10.4.0 , cereal , cereal-vector , containers >=0.5.5.1 , contravariant >=1.3 , criterion , cryptohash-sha1 >=0.11.6 , deepseq >=1.3.0.2 , directory >=1.2 , filepath >=1.3 , free >=4.11 , ghc-prim >=0.3.1.0 , hashable >=1.2.3.1 , hspec >=2.1.2 , hspec-smallcheck >=0.3.0 , lifted-base >=0.2.3.3 , monad-control >=0.3.3.0 , mono-traversable >=0.7.0 , nats >=1 , network >=2.6.0.2 , primitive >=0.6 , resourcet >=1.1.3.3 , safe >=0.3.8 , smallcheck >=1.1.1 , store , store-core ==0.4.* , syb >=0.4.4 , template-haskell >=2.9.0.0 , text >=1.2.0.4 , th-lift >=0.7.1 , th-lift-instances >=0.1.4 , th-orphans >=0.13.2 , th-reify-many >=0.1.6 , th-utilities >=0.2 , time >=1.5 , transformers >=0.3.0.0 , unordered-containers >=0.2.5.1 , vector >=0.10.12.3 , vector-binary-instances , void >=0.5.11 , weigh default-language: Haskell2010 if flag(integer-simple) build-depends: integer-simple >=0.1.1.1 else cpp-options: -DINTEGER_GMP build-depends: integer-gmp >=0.5.1.0 if impl(ghc < 8.0) build-depends: fail >=4.9 , semigroups >=0.8