{-# 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 { StoreVersion -> ByteString
unStoreVersion :: BS.ByteString }
    deriving (StoreVersion -> StoreVersion -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StoreVersion -> StoreVersion -> Bool
$c/= :: StoreVersion -> StoreVersion -> Bool
== :: StoreVersion -> StoreVersion -> Bool
$c== :: StoreVersion -> StoreVersion -> Bool
Eq, Int -> StoreVersion -> ShowS
[StoreVersion] -> ShowS
StoreVersion -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [StoreVersion] -> ShowS
$cshowList :: [StoreVersion] -> ShowS
show :: StoreVersion -> [Char]
$cshow :: StoreVersion -> [Char]
showsPrec :: Int -> StoreVersion -> ShowS
$cshowsPrec :: Int -> StoreVersion -> ShowS
Show, Eq StoreVersion
StoreVersion -> StoreVersion -> Bool
StoreVersion -> StoreVersion -> Ordering
StoreVersion -> StoreVersion -> StoreVersion
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: StoreVersion -> StoreVersion -> StoreVersion
$cmin :: StoreVersion -> StoreVersion -> StoreVersion
max :: StoreVersion -> StoreVersion -> StoreVersion
$cmax :: StoreVersion -> StoreVersion -> StoreVersion
>= :: StoreVersion -> StoreVersion -> Bool
$c>= :: StoreVersion -> StoreVersion -> Bool
> :: StoreVersion -> StoreVersion -> Bool
$c> :: StoreVersion -> StoreVersion -> Bool
<= :: StoreVersion -> StoreVersion -> Bool
$c<= :: StoreVersion -> StoreVersion -> Bool
< :: StoreVersion -> StoreVersion -> Bool
$c< :: StoreVersion -> StoreVersion -> Bool
compare :: StoreVersion -> StoreVersion -> Ordering
$ccompare :: StoreVersion -> StoreVersion -> Ordering
Ord, Typeable StoreVersion
StoreVersion -> DataType
StoreVersion -> Constr
(forall b. Data b => b -> b) -> StoreVersion -> StoreVersion
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> StoreVersion -> u
forall u. (forall d. Data d => d -> u) -> StoreVersion -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> StoreVersion -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> StoreVersion -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> StoreVersion -> m StoreVersion
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> StoreVersion -> m StoreVersion
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c StoreVersion
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> StoreVersion -> c StoreVersion
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c StoreVersion)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c StoreVersion)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> StoreVersion -> m StoreVersion
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> StoreVersion -> m StoreVersion
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> StoreVersion -> m StoreVersion
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> StoreVersion -> m StoreVersion
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> StoreVersion -> m StoreVersion
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> StoreVersion -> m StoreVersion
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> StoreVersion -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> StoreVersion -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> StoreVersion -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> StoreVersion -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> StoreVersion -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> StoreVersion -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> StoreVersion -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> StoreVersion -> r
gmapT :: (forall b. Data b => b -> b) -> StoreVersion -> StoreVersion
$cgmapT :: (forall b. Data b => b -> b) -> StoreVersion -> StoreVersion
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c StoreVersion)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c StoreVersion)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c StoreVersion)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c StoreVersion)
dataTypeOf :: StoreVersion -> DataType
$cdataTypeOf :: StoreVersion -> DataType
toConstr :: StoreVersion -> Constr
$ctoConstr :: StoreVersion -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c StoreVersion
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c StoreVersion
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> StoreVersion -> c StoreVersion
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> StoreVersion -> c StoreVersion
Data, Typeable, forall x. Rep StoreVersion x -> StoreVersion
forall x. StoreVersion -> Rep StoreVersion x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep StoreVersion x -> StoreVersion
$cfrom :: forall x. StoreVersion -> Rep StoreVersion x
Generic, Peek StoreVersion
Size StoreVersion
StoreVersion -> Poke ()
forall a. Size a -> (a -> Poke ()) -> Peek a -> Store a
peek :: Peek StoreVersion
$cpeek :: Peek StoreVersion
poke :: StoreVersion -> Poke ()
$cpoke :: StoreVersion -> Poke ()
size :: Size StoreVersion
$csize :: Size StoreVersion
Store)

-- | Configuration for the version checking of a particular type.
data VersionConfig a = VersionConfig
    { forall a. VersionConfig a -> Maybe [Char]
vcExpectedHash :: Maybe String
      -- ^ When set, specifies the hash which is expected to be computed.
    , forall a. VersionConfig a -> Maybe [Char]
vcManualName :: Maybe String
      -- ^ When set, specifies the name to instead use to tag the data.
    , forall a. VersionConfig a -> Set [Char]
vcIgnore :: S.Set String
      -- ^ DataTypes to ignore.
    , forall a. VersionConfig a -> Map [Char] [Char]
vcRenames :: M.Map String String
      -- ^ Allowed renamings of datatypes, useful when they move.
    } deriving (VersionConfig a -> VersionConfig a -> Bool
forall a. VersionConfig a -> VersionConfig a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VersionConfig a -> VersionConfig a -> Bool
$c/= :: forall a. VersionConfig a -> VersionConfig a -> Bool
== :: VersionConfig a -> VersionConfig a -> Bool
$c== :: forall a. VersionConfig a -> VersionConfig a -> Bool
Eq, Int -> VersionConfig a -> ShowS
forall a. Int -> VersionConfig a -> ShowS
forall a. [VersionConfig a] -> ShowS
forall a. VersionConfig a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [VersionConfig a] -> ShowS
$cshowList :: forall a. [VersionConfig a] -> ShowS
show :: VersionConfig a -> [Char]
$cshow :: forall a. VersionConfig a -> [Char]
showsPrec :: Int -> VersionConfig a -> ShowS
$cshowsPrec :: forall a. Int -> VersionConfig a -> ShowS
Show, VersionConfig a -> DataType
VersionConfig a -> Constr
forall {a}. Data a => Typeable (VersionConfig a)
forall a. Data a => VersionConfig a -> DataType
forall a. Data a => VersionConfig a -> Constr
forall a.
Data a =>
(forall b. Data b => b -> b) -> VersionConfig a -> VersionConfig a
forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> VersionConfig a -> u
forall a u.
Data a =>
(forall d. Data d => d -> u) -> VersionConfig a -> [u]
forall a r r'.
Data a =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> VersionConfig a -> r
forall a r r'.
Data a =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> VersionConfig a -> r
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d)
-> VersionConfig a -> m (VersionConfig a)
forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> VersionConfig a -> m (VersionConfig a)
forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (VersionConfig a)
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> VersionConfig a -> c (VersionConfig a)
forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (VersionConfig a))
forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (VersionConfig a))
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (VersionConfig a)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> VersionConfig a -> c (VersionConfig a)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (VersionConfig a))
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> VersionConfig a -> m (VersionConfig a)
$cgmapMo :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> VersionConfig a -> m (VersionConfig a)
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> VersionConfig a -> m (VersionConfig a)
$cgmapMp :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> VersionConfig a -> m (VersionConfig a)
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> VersionConfig a -> m (VersionConfig a)
$cgmapM :: forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d)
-> VersionConfig a -> m (VersionConfig a)
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> VersionConfig a -> u
$cgmapQi :: forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> VersionConfig a -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> VersionConfig a -> [u]
$cgmapQ :: forall a u.
Data a =>
(forall d. Data d => d -> u) -> VersionConfig a -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> VersionConfig a -> r
$cgmapQr :: forall a r r'.
Data a =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> VersionConfig a -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> VersionConfig a -> r
$cgmapQl :: forall a r r'.
Data a =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> VersionConfig a -> r
gmapT :: (forall b. Data b => b -> b) -> VersionConfig a -> VersionConfig a
$cgmapT :: forall a.
Data a =>
(forall b. Data b => b -> b) -> VersionConfig a -> VersionConfig a
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (VersionConfig a))
$cdataCast2 :: forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (VersionConfig a))
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (VersionConfig a))
$cdataCast1 :: forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (VersionConfig a))
dataTypeOf :: VersionConfig a -> DataType
$cdataTypeOf :: forall a. Data a => VersionConfig a -> DataType
toConstr :: VersionConfig a -> Constr
$ctoConstr :: forall a. Data a => VersionConfig a -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (VersionConfig a)
$cgunfold :: forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (VersionConfig a)
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> VersionConfig a -> c (VersionConfig a)
$cgfoldl :: forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> VersionConfig a -> c (VersionConfig a)
Data, Typeable, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (VersionConfig a) x -> VersionConfig a
forall a x. VersionConfig a -> Rep (VersionConfig a) x
$cto :: forall a x. Rep (VersionConfig a) x -> VersionConfig a
$cfrom :: forall a x. VersionConfig a -> Rep (VersionConfig a) x
Generic)

hashedVersionConfig :: String -> VersionConfig a
hashedVersionConfig :: forall a. [Char] -> VersionConfig a
hashedVersionConfig [Char]
hash = VersionConfig
    { vcExpectedHash :: Maybe [Char]
vcExpectedHash = forall a. a -> Maybe a
Just [Char]
hash
    , vcManualName :: Maybe [Char]
vcManualName = forall a. Maybe a
Nothing
    , vcIgnore :: Set [Char]
vcIgnore = forall a. Set a
S.empty
    , vcRenames :: Map [Char] [Char]
vcRenames = forall k a. Map k a
M.empty
    }

namedVersionConfig :: String -> String -> VersionConfig a
namedVersionConfig :: forall a. [Char] -> [Char] -> VersionConfig a
namedVersionConfig [Char]
name [Char]
hash = VersionConfig
    { vcExpectedHash :: Maybe [Char]
vcExpectedHash = forall a. a -> Maybe a
Just [Char]
hash
    , vcManualName :: Maybe [Char]
vcManualName = forall a. a -> Maybe a
Just [Char]
name
    , vcIgnore :: Set [Char]
vcIgnore = forall a. Set a
S.empty
    , vcRenames :: Map [Char] [Char]
vcRenames = forall k a. Map k a
M.empty
    }

encodeWithVersionQ :: Data a => VersionConfig a -> Q Exp
encodeWithVersionQ :: forall a. Data a => VersionConfig a -> Q Exp
encodeWithVersionQ = forall a. Data a => WhichFunc -> VersionConfig a -> Q Exp
impl WhichFunc
Encode

decodeWithVersionQ :: Data a => VersionConfig a -> Q Exp
decodeWithVersionQ :: forall a. Data a => VersionConfig a -> Q Exp
decodeWithVersionQ = forall a. Data a => WhichFunc -> VersionConfig a -> Q Exp
impl WhichFunc
Decode

data WhichFunc = Encode | Decode

impl :: forall a. Data a => WhichFunc -> VersionConfig a -> Q Exp
impl :: forall a. Data a => WhichFunc -> VersionConfig a -> Q Exp
impl WhichFunc
wf VersionConfig a
vc = do
    let proxy :: Proxy a
proxy = forall {k} (t :: k). Proxy t
Proxy :: Proxy a
        info :: ByteString
info = Text -> ByteString
encodeUtf8 ([Char] -> Text
T.pack (forall a.
Data a =>
Set [Char] -> Map [Char] [Char] -> Proxy a -> [Char]
getStructureInfo (forall a. VersionConfig a -> Set [Char]
vcIgnore VersionConfig a
vc) (forall a. VersionConfig a -> Map [Char] [Char]
vcRenames VersionConfig a
vc) Proxy a
proxy))
        hash :: ByteString
hash = ByteString -> ByteString
SHA1.hash ByteString
info
        hashb64 :: [Char]
hashb64 = ByteString -> [Char]
BS8.unpack (ByteString -> ByteString
B64Url.encode ByteString
hash)
        version :: Q Exp
version = case forall a. VersionConfig a -> Maybe [Char]
vcManualName VersionConfig a
vc of
            Maybe [Char]
Nothing -> [e| StoreVersion hash |]
            Just [Char]
name -> [e| StoreVersion name |]
    case forall a. VersionConfig a -> Maybe [Char]
vcExpectedHash VersionConfig a
vc of
        Maybe [Char]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just [Char]
expectedHash -> do
            let shownType :: [Char]
shownType = Map [Char] [Char] -> Int -> TypeRep -> ShowS
showsQualTypeRep (forall a. VersionConfig a -> Map [Char] [Char]
vcRenames VersionConfig a
vc) Int
0 (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy a
proxy) [Char]
""
            [Char]
path <- [Char] -> Q [Char]
storeVersionedPath [Char]
expectedHash
            if [Char]
hashb64 forall a. Eq a => a -> a -> Bool
== [Char]
expectedHash
                then [Char] -> [Char] -> ByteString -> Q ()
writeVersionInfo [Char]
path [Char]
shownType ByteString
info
                else do
                    [Char]
newPath <- [Char] -> Q [Char]
storeVersionedPath [Char]
hashb64
                    [Char] -> [Char] -> ByteString -> Q ()
writeVersionInfo [Char]
newPath [Char]
shownType ByteString
info
                    Bool
exists <- forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
doesFileExist [Char]
path
                    [Char]
extraMsg <- if Bool -> Bool
not Bool
exists
                        then forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
", but no file found with previously stored structural info."
                        else forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
", use something like the following to compare with the old structural info:\n\n" forall a. [a] -> [a] -> [a]
++
                                     [Char]
"diff -u " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
path forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
newPath)
                    forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
                        [Char]
"For " forall a. [a] -> [a] -> [a]
++ [Char]
shownType forall a. [a] -> [a] -> [a]
++ [Char]
",\n" forall a. [a] -> [a] -> [a]
++
                        [Char]
"Data.Store.Version expected hash " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
hashb64 forall a. [a] -> [a] -> [a]
++
                        [Char]
", but " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
expectedHash forall a. [a] -> [a] -> [a]
++ [Char]
" is specified.\n" forall a. [a] -> [a] -> [a]
++
                        [Char]
"The data used to construct the hash has been written to " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
newPath forall a. [a] -> [a] -> [a]
++
                        [Char]
extraMsg forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
    let atype :: Q Type
atype = TypeRep -> Q Type
typeRepToType (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy a
proxy)
    case WhichFunc
wf of
        WhichFunc
Encode -> [e| \x -> ( getSize markEncodedVersion + getSize $(version) + getSize x
                            , poke markEncodedVersion >> poke $(version) >> poke (x :: $(atype))) |]
        WhichFunc
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 :: [Char] -> [Char] -> ByteString -> Q ()
writeVersionInfo [Char]
path [Char]
shownType ByteString
info = forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ do
    Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory [Char]
path)
    [Char] -> Text -> IO ()
T.writeFile [Char]
path forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$
        [ [Char] -> Text
T.pack ([Char]
"-- Structural info for type " forall a. [a] -> [a] -> [a]
++ [Char]
shownType)
        , Text
"-- Generated by an invocation of functions in Data.Store.Version"
        ] forall a. [a] -> [a] -> [a]
++ Text -> [Text]
T.lines (ByteString -> Text
decodeUtf8 ByteString
info)

storeVersionedPath :: String -> Q FilePath
storeVersionedPath :: [Char] -> Q [Char]
storeVersionedPath [Char]
filename = do
    Maybe [Char]
mstack <- forall a. IO a -> Q a
runIO ([Char] -> IO (Maybe [Char])
lookupEnv [Char]
"STACK_EXE")
    let dirName :: [Char]
dirName = case Maybe [Char]
mstack of
            Just [Char]
_ -> [Char]
".stack-work"
            Maybe [Char]
Nothing -> [Char]
"dist"
    [Char] -> Q [Char]
pathRelativeToCabalPackage ([Char]
dirName [Char] -> ShowS
</> [Char]
"store-versioned" [Char] -> ShowS
</> [Char]
filename)

-- Implementation details

data S = S
    { S -> Map [Char] [Char]
sResults :: M.Map String String
    , S -> [Char]
sCurResult :: String
    , S -> [[Char]]
sFieldNames :: [String]
    }

getStructureInfo :: forall a. Data a => S.Set String -> M.Map String String -> Proxy a -> String
getStructureInfo :: forall a.
Data a =>
Set [Char] -> Map [Char] [Char] -> Proxy a -> [Char]
getStructureInfo Set [Char]
ignore Map [Char] [Char]
renames = Map [Char] [Char] -> [Char]
renderResults forall b c a. (b -> c) -> (a -> b) -> a -> c
. S -> Map [Char] [Char]
sResults forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> s
execState (Map [Char] [Char] -> [Char] -> [[Char]] -> S
S forall k a. Map k a
M.empty [Char]
"" []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
Data a =>
Set [Char] -> Map [Char] [Char] -> Proxy a -> State S ()
getStructureInfo' Set [Char]
ignore Map [Char] [Char]
renames
  where
    renderResults :: Map [Char] [Char] -> [Char]
renderResults = [[Char]] -> [Char]
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\([Char]
k, [Char]
v) -> [Char]
k forall a. [a] -> [a] -> [a]
++ [Char]
v) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.toAscList

getStructureInfo' :: forall a. Data a => S.Set String -> M.Map String String -> Proxy a -> State S ()
getStructureInfo' :: forall a.
Data a =>
Set [Char] -> Map [Char] [Char] -> Proxy a -> State S ()
getStructureInfo' Set [Char]
ignore Map [Char] [Char]
renames Proxy a
_ = do
    S
s0 <- forall (m :: * -> *) s. Monad m => StateT s m s
get
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall k a. Ord k => k -> Map k a -> Bool
M.notMember [Char]
label (S -> Map [Char] [Char]
sResults S
s0)) forall a b. (a -> b) -> a -> b
$
        if forall a. Ord a => a -> Set a -> Bool
S.member [Char]
shownType Set [Char]
ignore
            then forall {m :: * -> *}. Monad m => [Char] -> StateT S m ()
setResult [Char]
" ignored\n"
            else case DataType -> DataRep
dataTypeRep (forall a. Data a => a -> DataType
dataTypeOf (forall a. HasCallStack => a
undefined :: a)) of
                AlgRep [Constr]
cs -> do
                    forall {m :: * -> *}. Monad m => [Char] -> StateT S m ()
setResult [Char]
""
                    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool, Constr) -> State S ()
goConstr (forall a b. [a] -> [b] -> [(a, b)]
zip (Bool
True forall a. a -> [a] -> [a]
: forall a. a -> [a]
repeat Bool
False) [Constr]
cs)
                    [Char]
result <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets S -> [Char]
sCurResult
                    forall {m :: * -> *}. Monad m => [Char] -> StateT S m ()
setResult (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Constr]
cs then [Char]
result forall a. [a] -> [a] -> [a]
++ [Char]
"\n" else [Char]
result)
                DataRep
IntRep -> forall {m :: * -> *}. Monad m => [Char] -> StateT S m ()
setResult [Char]
" has IntRep\n"
                DataRep
FloatRep -> forall {m :: * -> *}. Monad m => [Char] -> StateT S m ()
setResult [Char]
" has FloatRep\n"
                DataRep
CharRep -> forall {m :: * -> *}. Monad m => [Char] -> StateT S m ()
setResult [Char]
" has CharRep\n"
                DataRep
NoRep
                    | forall a. Ord a => a -> Set a -> Bool
S.member [Char]
shownType Set [Char]
ignore -> forall {m :: * -> *}. Monad m => [Char] -> StateT S m ()
setResult [Char]
" has NoRep\n"
                    | Bool
otherwise -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
                        [Char]
"\nNoRep in Data.Store.Version for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
shownType forall a. [a] -> [a] -> [a]
++
                        [Char]
".\nIn the future it will be possible to statically " forall a. [a] -> [a] -> [a]
++
                        [Char]
"declare a global serialization version for this type. " forall a. [a] -> [a] -> [a]
++
                        [Char]
"\nUntil then you will need to use 'vcIgnore', and " forall a. [a] -> [a] -> [a]
++
                        [Char]
"understand that serialization changes for affected types " forall a. [a] -> [a] -> [a]
++
                        [Char]
"will not be detected.\n"
  where
    setResult :: [Char] -> StateT S m ()
setResult [Char]
x =
         forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\S
s -> S
             { sResults :: Map [Char] [Char]
sResults = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert [Char]
label [Char]
x (S -> Map [Char] [Char]
sResults S
s)
             , sCurResult :: [Char]
sCurResult = [Char]
""
             , sFieldNames :: [[Char]]
sFieldNames = []
             })
    label :: [Char]
label = [Char]
"data-type " forall a. [a] -> [a] -> [a]
++ [Char]
shownType
    shownType :: [Char]
shownType = Map [Char] [Char] -> Int -> TypeRep -> ShowS
showsQualTypeRep Map [Char] [Char]
renames Int
0 (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)) [Char]
""
    goConstr :: (Bool, Constr) -> State S ()
    goConstr :: (Bool, Constr) -> State S ()
goConstr (Bool
isFirst, Constr
c) = do
        forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\S
s -> S
s
            { sFieldNames :: [[Char]]
sFieldNames = Constr -> [[Char]]
constrFields Constr
c forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (\Int
ix -> [Char]
"slot " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Int
ix :: Int)) [Int
0..]
            , sCurResult :: [Char]
sCurResult = S -> [Char]
sCurResult S
s forall a. [a] -> [a] -> [a]
++ (if Bool
isFirst then [Char]
"\n  = " else [Char]
"  | ") forall a. [a] -> [a] -> [a]
++ Constr -> [Char]
showConstr Constr
c forall a. [a] -> [a] -> [a]
++ [Char]
" {\n"
            })
        forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (m :: * -> *) a.
(Monad m, Data a) =>
(forall d. Data d => m d) -> Constr -> m a
fromConstrM forall b. Data b => State S b
goField Constr
c :: State S a)
        forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\S
s -> S
s { sCurResult :: [Char]
sCurResult = S -> [Char]
sCurResult S
s forall a. [a] -> [a] -> [a]
++ [Char]
"  }\n" })
    goField :: forall b. Data b => State S b
    goField :: forall b. Data b => State S b
goField = do
        S
s <- forall (m :: * -> *) s. Monad m => StateT s m s
get
        case S -> [[Char]]
sFieldNames S
s of
            [] -> forall a. HasCallStack => [Char] -> a
error [Char]
"impossible case in getStructureInfo'"
            ([Char]
name:[[Char]]
names) -> do
                forall a.
Data a =>
Set [Char] -> Map [Char] [Char] -> Proxy a -> State S ()
getStructureInfo' Set [Char]
ignore Map [Char] [Char]
renames (forall {k} (t :: k). Proxy t
Proxy :: Proxy b)
                S
s' <- forall (m :: * -> *) s. Monad m => StateT s m s
get
                forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put S
s
                    { sResults :: Map [Char] [Char]
sResults = S -> Map [Char] [Char]
sResults S
s'
                    , sCurResult :: [Char]
sCurResult = S -> [Char]
sCurResult S
s forall a. [a] -> [a] -> [a]
++ [Char]
"    " forall a. [a] -> [a] -> [a]
++ [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
" :: " forall a. [a] -> [a] -> [a]
++ Map [Char] [Char] -> Int -> TypeRep -> ShowS
showsQualTypeRep Map [Char] [Char]
renames Int
0 (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy b)) [Char]
"\n"
                    , sFieldNames :: [[Char]]
sFieldNames = [[Char]]
names
                    }
                forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. HasCallStack => [Char] -> a
error [Char]
"unexpected evaluation")

showsQualTypeRep :: M.Map String String -> Int -> TypeRep -> ShowS
showsQualTypeRep :: Map [Char] [Char] -> Int -> TypeRep -> ShowS
showsQualTypeRep Map [Char] [Char]
renames Int
p TypeRep
tyrep =
  let (TyCon
tycon, [TypeRep]
tys) = TypeRep -> (TyCon, [TypeRep])
splitTyConApp TypeRep
tyrep
  in case [TypeRep]
tys of
        [] -> Map [Char] [Char] -> TyCon -> ShowS
showsQualTyCon Map [Char] [Char]
renames TyCon
tycon
        [TypeRep
x] | TyCon
tycon forall a. Eq a => a -> a -> Bool
== TyCon
tcList -> Char -> ShowS
showChar Char
'[' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map [Char] [Char] -> Int -> TypeRep -> ShowS
showsQualTypeRep Map [Char] [Char]
renames Int
0 TypeRep
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
']'
          where
        [TypeRep
a,TypeRep
r] | TyCon
tycon forall a. Eq a => a -> a -> Bool
== TyCon
tcFun  -> Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
> Int
8) forall a b. (a -> b) -> a -> b
$
                                     Map [Char] [Char] -> Int -> TypeRep -> ShowS
showsQualTypeRep Map [Char] [Char]
renames Int
9 TypeRep
a forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                     [Char] -> ShowS
showString [Char]
" -> " forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                     Map [Char] [Char] -> Int -> TypeRep -> ShowS
showsQualTypeRep Map [Char] [Char]
renames Int
8 TypeRep
r
        [TypeRep]
xs | TyCon -> Bool
isTupleTyCon TyCon
tycon -> Map [Char] [Char] -> [TypeRep] -> ShowS
showTuple Map [Char] [Char]
renames [TypeRep]
xs
           | Bool
otherwise         ->
                Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
> Int
9) forall a b. (a -> b) -> a -> b
$
                Map [Char] [Char] -> TyCon -> ShowS
showsQualTyCon Map [Char] [Char]
renames TyCon
tycon forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                Char -> ShowS
showChar Char
' '      forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                Map [Char] [Char] -> ShowS -> [TypeRep] -> ShowS
showArgs Map [Char] [Char]
renames (Char -> ShowS
showChar Char
' ') [TypeRep]
tys

showsQualTyCon :: M.Map String String -> TyCon -> ShowS
showsQualTyCon :: Map [Char] [Char] -> TyCon -> ShowS
showsQualTyCon Map [Char] [Char]
renames TyCon
tc = [Char] -> ShowS
showString (forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [Char]
name [Char]
name Map [Char] [Char]
renames)
  where
    name :: [Char]
name = TyCon -> [Char]
tyConModule TyCon
tc forall a. [a] -> [a] -> [a]
++ [Char]
"." forall a. [a] -> [a] -> [a]
++ TyCon -> [Char]
tyConName TyCon
tc

isTupleTyCon :: TyCon -> Bool
isTupleTyCon :: TyCon -> Bool
isTupleTyCon TyCon
tc
  | (Char
'(':Char
',':[Char]
_) <- TyCon -> [Char]
tyConName TyCon
tc = Bool
True
  | Bool
otherwise                   = Bool
False

showArgs :: M.Map String String -> ShowS -> [TypeRep] -> ShowS
showArgs :: Map [Char] [Char] -> ShowS -> [TypeRep] -> ShowS
showArgs Map [Char] [Char]
_       ShowS
_   []     = forall a. a -> a
id
showArgs Map [Char] [Char]
renames ShowS
_   [TypeRep
a]    = Map [Char] [Char] -> Int -> TypeRep -> ShowS
showsQualTypeRep Map [Char] [Char]
renames Int
10 TypeRep
a
showArgs Map [Char] [Char]
renames ShowS
sep (TypeRep
a:[TypeRep]
as) = Map [Char] [Char] -> Int -> TypeRep -> ShowS
showsQualTypeRep Map [Char] [Char]
renames Int
10 TypeRep
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
sep forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map [Char] [Char] -> ShowS -> [TypeRep] -> ShowS
showArgs Map [Char] [Char]
renames ShowS
sep [TypeRep]
as

showTuple :: M.Map String String -> [TypeRep] -> ShowS
showTuple :: Map [Char] [Char] -> [TypeRep] -> ShowS
showTuple Map [Char] [Char]
renames [TypeRep]
args
    = Char -> ShowS
showChar Char
'('
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map [Char] [Char] -> ShowS -> [TypeRep] -> ShowS
showArgs Map [Char] [Char]
renames (Char -> ShowS
showChar Char
',') [TypeRep]
args
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
')'

tcList :: TyCon
tcList :: TyCon
tcList = forall a. Typeable a => Proxy a -> TyCon
tyConOf (forall {k} (t :: k). Proxy t
Proxy :: Proxy [()])

tcFun :: TyCon
tcFun :: TyCon
tcFun = forall a. Typeable a => Proxy a -> TyCon
tyConOf (forall {k} (t :: k). Proxy t
Proxy :: Proxy (Int -> Int))

tyConOf :: Typeable a => Proxy a -> TyCon
tyConOf :: forall a. Typeable a => Proxy a -> TyCon
tyConOf = TypeRep -> TyCon
typeRepTyCon forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep

displayVersionError :: StoreVersion -> StoreVersion -> String
displayVersionError :: StoreVersion -> StoreVersion -> [Char]
displayVersionError StoreVersion
expectedVersion StoreVersion
receivedVersion =
    [Char]
"Mismatch detected by Data.Store.Version - expected " forall a. [a] -> [a] -> [a]
++
    Text -> [Char]
T.unpack (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (StoreVersion -> ByteString
unStoreVersion StoreVersion
expectedVersion)) forall a. [a] -> [a] -> [a]
++ [Char]
" but got " forall a. [a] -> [a] -> [a]
++
    Text -> [Char]
T.unpack (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (StoreVersion -> ByteString
unStoreVersion StoreVersion
receivedVersion))

markEncodedVersion :: Word32
markEncodedVersion :: Word32
markEncodedVersion = Word32
3908297288