safe-json-1.1.0: src/Data/SafeJSON/Internal.hs
-- This module heavily relies on code borrowed from the "safecopy"
-- library by David Himmelstrup and Felipe Lessa, found on
-- "https://github.com/acid-state/safecopy"
--
-- Though it has gone through extensive refactoring because of
-- desired behaviour being different from the safecopy library
-- and the fact that this library works with JSON, instead of
-- byte serialization.
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-|
Module : Data.SafeJSON.Internal
Copyright : (c) 2019 Felix Paulusma
License : MIT
Maintainer : felix.paulusma@gmail.com
Stability : experimental
This module contains all "under-the-hood" functions
and types. "Data.SafeJSON" exports everything for the
outward-facing API.
-}
module Data.SafeJSON.Internal where
import Control.Applicative (Applicative(..), Const(..), (<|>))
import Control.Monad (when)
import Control.Monad.Fail (MonadFail)
import Data.Aeson
import Data.Aeson.Types (Parser, explicitParseField, explicitParseFieldMaybe, explicitParseFieldMaybe')
import Data.DList as DList (DList, fromList)
import Data.Fixed (Fixed, HasResolution)
import Data.Functor.Identity (Identity(..))
import Data.Functor.Compose (Compose) -- FIXME: add SafeJSON Instances
import Data.Functor.Product (Product) -- FIXME: add SafeJSON Instances
import Data.Functor.Sum (Sum(..)) -- FIXME: add SafeJSON Instances
import Data.Hashable (Hashable)
import Data.HashMap.Strict as HM (insert, size)
import qualified Data.HashMap.Strict as HM (HashMap, delete, fromList, lookup, toList)
import qualified Data.HashSet as HS (HashSet, fromList, toList)
import Data.Int
import Data.IntMap as IM (IntMap, fromList)
import Data.IntSet (IntSet)
import qualified Data.List as List (intercalate, lookup)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Map (Map)
import Data.Maybe (fromMaybe, isJust, isNothing)
#if MIN_VERSION_base(4,11,0)
import Data.Monoid (Dual(..))
#else
import Data.Monoid (Dual(..), (<>))
#endif
import Data.Proxy
import Data.Ratio (Ratio)
import Data.Scientific (Scientific)
import Data.Semigroup (First(..), Last(..), Max(..), Min(..))
import Data.Sequence (Seq)
import qualified Data.Set as S
import Data.Text as T (Text)
import qualified Data.Text.Lazy as LT (Text)
import Data.Time
import Data.Tree (Tree)
import Data.Typeable (Typeable, typeRep)
import Data.UUID.Types (UUID)
import qualified Data.Vector as V
import qualified Data.Vector.Generic as VG
import qualified Data.Vector.Primitive as VP
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Unboxed as VU
import qualified Data.Version as DV (Version)
import Data.Void (Void)
import Data.Word (Word8, Word16, Word32, Word64)
import Foreign.C.Types (CTime)
import Numeric.Natural (Natural)
import Test.Tasty.QuickCheck (Arbitrary(..), shrinkIntegral)
-- | A type that can be converted from and to JSON with versioning baked
-- in, using 'Migrate' to automate migration between versions, reducing
-- headaches when the need arrises to modify JSON formats while old
-- formats can't simply be disregarded.
class SafeJSON a where
-- | The version of the type.
--
-- Only used as a key so it __must be unique__ (this is checked at run-time)
--
-- Version numbering __doesn't have to be sequential or continuous__.
--
-- /The default version is 0 (zero)./
version :: Version a
version = 0
-- | The kind specifies how versions are dealt with. By default,
-- values are tagged with version 0 and don't have any
-- previous versions.
--
-- /The default kind is/ 'base'
kind :: Kind a
kind = Base
-- | This method defines how a value should be serialized without worrying
-- about adding the version. The default implementation uses 'toJSON', but
-- can be modified if need be.
--
-- This function cannot be used directly. Use 'safeToJSON', instead.
safeTo :: a -> Contained Value
default safeTo :: ToJSON a => a -> Contained Value
safeTo = contain . toJSON
-- | This method defines how a value should be parsed without also worrying
-- about writing out the version tag. The default implementation uses 'parseJSON',
-- but can be modified if need be.
--
-- This function cannot be used directly. Use 'safeFromJSON', instead.
safeFrom :: Value -> Contained (Parser a)
default safeFrom :: FromJSON a => Value -> Contained (Parser a)
safeFrom = contain . parseJSON
-- | The name of the type. This is used in error message strings and the
-- 'Profile' report.
--
-- Doesn't have to be defined if your type is 'Data.Typeable.Typeable'. The default
-- implementation is 'typeName0'. (cf. 'typeName1', 'typeName2', etc.)
typeName :: Proxy a -> String
default typeName :: Typeable a => Proxy a -> String
typeName = typeName0
-- Internal function that should not be overrided.
-- @Consistent@ if the version history is consistent
-- (i.e. there are no duplicate version numbers) and
-- the chain of migrations is valid.
--
-- This function is in the typeclass so that this
-- information is calculated only once during the program
-- lifetime, instead of everytime 'safeFrom' or 'safeTo' is used.
internalConsistency :: Consistency a
internalConsistency = computeConsistency Proxy
-- | Version profile.
--
-- Shows the current version of the type and all supported
-- versions it can migrate from.
objectProfile :: Profile a
objectProfile = mkProfile Proxy
{-# MINIMAL #-}
-- | This instance is needed to handle the migration between
-- older and newer versions.
--
-- Note that, where @('Migrate' a)@ migrates from the previous
-- version to the type @a@, @('Migrate' ('Reverse' a))@ migrates
-- from the future version to the type @a@.
--
-- === __Example__
--
-- __Two types that can migrate to each other.__
--
-- (Don't forget to give @OldType@ one of the @extended@ 'kind's,
-- and @NewType@ one of the @extension@ 'kind's.)
--
-- @
-- instance 'Migrate' NewType where
-- type 'MigrateFrom' NewType = OldType
-- 'migrate' OldType = NewType
--
-- instance 'Migrate' ('Reverse' OldType) where
-- type 'MigrateFrom' ('Reverse' OldType) = NewType
-- 'migrate' NewType = 'Reverse' OldType
-- @
class SafeJSON (MigrateFrom a) => Migrate a where
-- | The type from which will be migrated to type @a@
type MigrateFrom a
-- | The migration from the previous version to the
-- current type @a@. OR, in case of a @('Reverse' a)@,
-- the migration from the future version back to
-- the current type @a@
migrate :: MigrateFrom a -> a
-- | This is an impenetrable container. A security measure
-- used to ensure 'safeFrom' and 'safeTo' are never used
-- directly. Instead, always use 'safeFromJSON' and
-- 'safeToJSON'.
newtype Contained a = Contained {unsafeUnpack :: a}
-- Opens up mis-use of 'safeFrom' / 'safeTo', better to not
-- deriving (Functor)
-- | Used when defining 'safeFrom' or 'safeTo'.
contain :: a -> Contained a
contain = Contained
-- | A simple numeric version id.
--
-- 'Version' has a 'Num' instance and should be
-- declared using integer literals: @'version' = 2@
newtype Version a = Version {unVersion :: Maybe Int32}
deriving (Eq)
-- | This is used for types that don't have
-- a version tag.
--
-- This is used for primitive values that are not tagged with
-- a version number, like @Int@, @Text@, @[a]@, etc.
--
-- But also when implementing 'SafeJSON' after the fact,
-- when a format is already in use, but you still want to
-- be able to 'migrate' from it to a newer type or format.
--
-- /N.B./ @'version' = 'noVersion'@ /is distinctively different/
-- /from/ @'version' = 0@/, which will add a version tag with/
-- /the number 0 (zero), whereas/ 'noVersion' /will not add a/
-- /'version' tag./
noVersion :: Version a
noVersion = Version Nothing
-- | Same as 'setVersion', but requires a 'Version' parameter.
--
-- >>> 'encode' $ 'setVersion'' ('version' :: 'Version' Test) val
-- "{\"~v\":0,\"~d\":\"test\"}"
--
-- @since 1.0.0
setVersion' :: forall a. SafeJSON a => Version a -> Value -> Value
setVersion' (Version mVersion) val =
case mVersion of
Nothing -> val
Just i -> case val of
Object o ->
let vField = maybe versionField
(const dataVersionField)
$ dataVersionField `HM.lookup` o
in Object $ HM.insert vField (toJSON i) o
other -> object
[ dataVersionField .= i
, dataField .= other
]
-- | /CAUTION: Only use this function if you know what you're doing./
-- /The version will be set top-level, without inspection of the 'Value'!/
--
-- (cf. 'removeVersion') In some rare cases, you might want to interpret
-- a versionless 'Value' as a certain type/version. 'setVersion' allows
-- you to (unsafely) insert a version field.
--
-- __If possible, it is advised to use a 'FromJSON' instance instead.__
-- (One that doesn't also use `safeFromJSON` in its methods!)
--
-- This might be needed when data sent to an API endpoint doesn't
-- need to implement SafeJSON standards. E.g. in the case of
-- endpoints for third parties or customers.
--
-- @
-- USAGE:
--
-- {-\# LANGUAGE TypeApplications \#-}
-- data Test = Test String
-- instance 'SafeJSON' Test where ...
--
-- >>> val = 'Data.Aeson.String' "test" :: 'Value'
-- String "test"
-- >>> 'encode' val
-- "\"test\""
-- >>> 'encode' $ 'setVersion' \@Test val
-- "{\"~v\":0,\"~d\":\"test\"}"
-- >>> parseMaybe 'safeFromJSON' $ 'setVersion' \@Test val
-- Just (Test "test")
-- @
--
-- @since 1.0.0
setVersion :: forall a. SafeJSON a => Value -> Value
setVersion = setVersion' (version @a)
-- | /CAUTION: Only use this function if you know what you're doing./
--
-- (cf. 'setVersion') 'removeVersion' removes all the 'SafeJSON'
-- versioning from a JSON 'Value'. Even recursively.
--
-- This might be necessary if the resulting JSON is sent to a
-- third party (e.g. customer) and the 'SafeJSON' versioning
-- should be hidden.
--
-- @since 1.0.0
removeVersion :: Value -> Value
removeVersion = \case
Object o -> go o
-- Recursively find all version tags and remove them.
Array a -> Array $ removeVersion <$> a
other -> other
-- Recursively find all version tags and remove them.
where go o = maybe regular removeVersion $ do
_ <- dataVersionField `HM.lookup` o
dataField `HM.lookup` o
where regular = Object $ removeVersion <$> HM.delete versionField o
instance Show (Version a) where
show (Version mi) = "Version " ++ showV mi
liftV :: Integer -> (Int32 -> Int32 -> Int32) -> Maybe Int32 -> Maybe Int32 -> Maybe Int32
liftV _ _ Nothing Nothing = Nothing
liftV i f ma mb = Just $ toZ ma `f` toZ mb
where toZ = fromMaybe $ fromInteger i
-- 'Version Nothing' is handled as if it's mempty... mostly.
-- | It is strongly discouraged to use any methods other
-- than 'fromInteger' of 'Version'\'s 'Num' instance.
instance Num (Version a) where
Version ma + Version mb = Version $ liftV 0 (+) ma mb
Version ma - Version mb = Version $ liftV 0 (-) ma mb
Version ma * Version mb = Version $ liftV 1 (*) ma mb
negate (Version ma) = Version $ negate <$> ma
abs (Version ma) = Version $ abs <$> ma
signum (Version ma) = Version $ signum <$> ma
fromInteger i = Version $ Just $ fromInteger i
-- | This instance explicitly doesn't consider 'noVersion', since it
-- is an exception in almost every sense.
instance Arbitrary (Version a) where
arbitrary = Version . Just <$> arbitrary
shrink (Version Nothing) = []
shrink (Version (Just a)) = Version . Just <$> shrinkIntegral a
castVersion :: Version a -> Version b
castVersion (Version i) = Version i
-- | This is a wrapper type used migrating backwards in the chain of compatible types.
--
-- This is useful when running updates in production where new-format JSON will be
-- received by old-format expecting programs.
newtype Reverse a = Reverse { unReverse :: a }
-- | The 'kind' of a 'SafeJSON' type determines how it can be migrated to.
data Kind a where
Base :: Kind a
Extends :: Migrate a => Proxy (MigrateFrom a) -> Kind a
Extended :: Migrate (Reverse a) => Kind a -> Kind a
-- | Used to define 'kind'.
-- @Base@ types do not extend any type.
base :: Kind a
base = Base
-- | Used to define 'kind'.
-- Extends a previous version.
extension :: (SafeJSON a, Migrate a) => Kind a
extension = Extends Proxy
-- | Used to define 'kind'.
-- Types that are 'extended_base', are extended by a
-- future version and as such can migrate backward from
-- that future version. (cf. 'extended_extension', 'base')
extended_base :: (SafeJSON a, Migrate (Reverse a)) => Kind a
extended_base = Extended base
-- | Used to define 'kind'.
-- Types that are 'extended_extension' are extended
-- by a future version and as such can migrate from
-- that future version, but they also extend a previous
-- version. (cf. 'extended_base', 'extension')
extended_extension :: (SafeJSON a, Migrate a, Migrate (Reverse a)) => Kind a
extended_extension = Extended extension
-- The '!' and '~' used in these set fields are chosen for their
-- low probability of showing up naturally in JSON objects one
-- would normally find or construct.
versionField :: Text
versionField = "!v"
dataVersionField :: Text
dataVersionField = "~v"
dataField :: Text
dataField = "~d"
-- | Use this exactly how you would use 'toJSON' from "Data.Aeson".
-- Though most use cases will probably use one of the 'Data.Aeson.Safe.encode'
-- functions from "Data.Aeson.Safe".
--
-- 'safeToJSON' will add a version tag to the 'Data.Aeson.Value' created.
-- If the 'Data.Aeson.Value' resulting from 'safeTo' (by default the same as 'toJSON')
-- is an @'Object'@, an extra field with the version number will be added.
--
-- > Example value:
-- > {"type":"test", "data":true}
-- >
-- > Resulting object:
-- > {"!v": 1, "type":"test", "data":true}
--
-- If the resulting 'Value' is not an @'Object'@, it will be wrapped
-- in one, with a version field:
--
-- > Example value:
-- > "arbitrary string"
-- >
-- > Resulting object:
-- > {"~v": 1, "~d": "arbitrary string"}
--
-- __This function does not check consistency of the 'SafeJSON' instances.__
-- __It is advised to always 'Data.SafeJSON.Test.testConsistency' for all__
-- __your instances in a production setting.__
safeToJSON :: forall a. SafeJSON a => a -> Value
safeToJSON a = case thisKind of
Base | i == Nothing -> tojson
Extended Base | i == Nothing -> tojson
_ -> setVersion @a tojson
where tojson = unsafeUnpack $ safeTo a
Version i = version :: Version a
thisKind = kind :: Kind a
-- The consistency is checked on first parse, after that
-- there is no overhead.
-- | Use this exactly how you would use 'parseJSON' from "Data.Aeson".
-- Though most use cases will probably use one of the 'Data.Aeson.Safe.decode'
-- functions from "Data.Aeson.Safe".
--
-- 'safeFromJSON' tries to find the version number in the JSON
-- 'Value' provided, find the appropriate parser and migrate the
-- parsed result back to the requested type using 'Migrate'
-- instances.
--
-- If there is no version number (that means this can also happen with
-- completely unrelated JSON messages), and there is a 'SafeJSON'
-- instance in the chain that has 'version' defined as 'noVersion',
-- it will try to parse that type.
--
-- __N.B. If the consistency of the 'SafeJSON' instance in__
-- __question is faulty, this will always fail.__
safeFromJSON :: forall a. SafeJSON a => Value -> Parser a
safeFromJSON origVal = checkConsistency p $ \vs -> do
let hasVNil = noVersionPresent vs
case origKind of
Base | i == Nothing -> unsafeUnpack $ safeFrom origVal
Extended k | i == Nothing -> extendedCase hasVNil k
_ -> regularCase hasVNil
where Version i = version :: Version a
origKind = kind :: Kind a
p = Proxy :: Proxy a
safejsonErr s = fail $ "safejson: " ++ s
regularCase hasVNil = case origVal of
Object o -> do
(val, v) <- tryIt o
withVersion v val origKind
_ -> withoutVersion <|> safejsonErr ("unparsable JSON value (not an object): " ++ typeName p)
where withoutVersion = withVersion noVersion origVal origKind
tryIt o
| hasVNil = firstTry o <|> secondTry o <|> pure (origVal, noVersion)
| otherwise = firstTry o <|> secondTry o
-- This only runs if the SafeJSON being tried has 'kind' of 'extended_*'
-- and the version is 'noVersion'.
-- (internalConsistency checks that it should be an 'Extended Base' since it has 'noVersion')
-- We check the newer version first, since it's better to try to find the
-- version, if there is one, to guarantee the right parser.
extendedCase :: Migrate (Reverse a) => Bool -> Kind a -> Parser a
extendedCase hasVNil k = case k of { Base -> go; _ -> regularCase hasVNil }
where go = case origVal of
Object o -> tryNew o <|> tryOrig
_ -> tryOrig
tryNew o = do
(val, v) <- firstTry o <|> secondTry o
let forwardKind = getForwardKind k
forwardVersion = castVersion v
getForwardParser = withVersion forwardVersion val forwardKind
unReverse . migrate <$> getForwardParser
tryOrig = unsafeUnpack $ safeFrom origVal
withVersion :: forall b. SafeJSON b => Version b -> Value -> Kind b -> Parser b
withVersion v val k = either fail id eResult
where eResult = constructParserFromVersion val v k
firstTry o = do
v <- o .: versionField
let versionLessObj = HM.delete versionField o
return (Object versionLessObj, Version $ Just v)
secondTry o = do
v <- o .: dataVersionField
bd <- o .: dataField
-- This is an extra counter measure against false parsing.
-- The simple data object should contain exactly the
-- (~v) and (~d) fields
when (HM.size o /= 2) $ fail $ "malformed simple data (" ++ show (Version $ Just v) ++ ")"
return (bd, Version $ Just v)
-- This takes the version number found (or Nothing) and tries find the type in
-- the chain that has that version number. It will attempt to go one type up
-- (try 'Migrate (Reverse a)' once) and after that down the chain.
constructParserFromVersion :: SafeJSON a => Value -> Version a -> Kind a -> Either String (Parser a)
constructParserFromVersion val origVersion origKind =
worker False origVersion origKind
where
worker :: forall b. SafeJSON b => Bool -> Version b -> Kind b -> Either String (Parser b)
worker fwd thisVersion thisKind
| version == thisVersion = return $ unsafeUnpack $ safeFrom val
| otherwise = case thisKind of
Base -> Left versionNotFound
Extends p -> fmap migrate <$> worker fwd (castVersion thisVersion) (kindFromProxy p)
Extended k -> do
-- Technically, the forward and backward parsing could be
-- infinite, as long as all 'Migrate' instances are defined.
-- The problem is that chains can fork if, after going forward,
-- the kind of that forward type is used to continue, since
-- there's no guarantee that the migrations will continue backward
-- down the previous chain.
--
-- TODO: Somehow restrict Migrate instances in such a way that, if defined:
-- > MigrateFrom (Reverse b) = a
-- > THEN ALSO
-- > MigrateFrom a = b
--
-- @
-- v1 Base v1' Base v1'' Ext_Base
-- | | /\
-- | | |
-- \/ \/ \/
-- v2 Exs -> v3 Ext_Exs -> v4 Exs
-- @
--
-- I've opted for the following approach:
-- "Try forward once, if the version is wrong, go down your own chain"
--
-- IDEA: Maybe it could be written in such a way that the backward type
-- (Base or Extends) in the Extended data constructor is passed along on
-- up the chain until the top is reached, after which the run downward
-- starts with Extends, or the run ends in case it was a Base type.
let forwardParser :: Either String (Parser b)
forwardParser = do
if castVersion thisVersion == versionFromProxy reverseProxy
then Right $ unReverse . migrate <$> unsafeUnpack (safeFrom val)
else previousParser
previousParser :: Either String (Parser b)
previousParser = worker True thisVersion k
-- If we've already looked ahead, or if it's 'noVersion', we go back.
-- ('noVersion' means we need to find the 'Base', that's always backwards)
if fwd || thisVersion == noVersion
then previousParser
else either (const previousParser) Right forwardParser
where versionNotFound = "Cannot find parser associated with: " <> show origVersion
reverseProxy :: Proxy (MigrateFrom (Reverse b))
reverseProxy = Proxy
-- | Type name string representation of a __nullary__ type constructor.
typeName0 :: Typeable a => Proxy a -> String
typeName0 = show . typeRep
-- | Type name string representation of a __unary__ type constructor.
typeName1 :: forall t a. Typeable t => Proxy (t a) -> String
typeName1 _ = show $ typeRep (Proxy :: Proxy t)
-- | Type name string representation of a __binary__ type constructor.
typeName2 :: forall t a b. Typeable t => Proxy (t a b) -> String
typeName2 _ = show $ typeRep (Proxy :: Proxy t)
-- | Type name string representation of a __ternary__ type constructor.
typeName3 :: forall t a b c. Typeable t => Proxy (t a b c) -> String
typeName3 _ = show $ typeRep (Proxy :: Proxy t)
-- | Type name string representation of a __4-ary__ type constructor.
typeName4 :: forall t a b c d. Typeable t => Proxy (t a b c d) -> String
typeName4 _ = show $ typeRep (Proxy :: Proxy t)
-- | Type name string representation of a __5-ary__ type constructor.
typeName5 :: forall t a b c d e. Typeable t => Proxy (t a b c d e) -> String
typeName5 _ = show $ typeRep (Proxy :: Proxy t)
-- | Profile of the internal consistency of a 'SafeJSON' instance.
--
-- /N.B. 'noVersion' shows as/ @null@ /instead of a number./
data Profile a = InvalidProfile String -- ^ There is something wrong with versioning
| Profile ProfileVersions -- ^ Profile of consistent versions
deriving (Eq)
-- | Version profile of a consistent 'SafeJSON' instance.
data ProfileVersions = ProfileVersions {
profileCurrentVersion :: Maybe Int32, -- ^ Version of the type checked for consistency.
profileSupportedVersions :: [(Maybe Int32, String)] -- ^ All versions in the chain with their type names.
} deriving (Eq)
noVersionPresent :: ProfileVersions -> Bool
noVersionPresent (ProfileVersions c vs) =
isNothing c || isJust (Nothing `List.lookup` vs)
showV :: Maybe Int32 -> String
showV Nothing = "null"
showV (Just i) = show i
showVs :: [(Maybe Int32, String)] -> String
showVs = List.intercalate ", " . fmap go
where go (mi, s) = mconcat ["(", showV mi, ", ", s, ")"]
-- | @'Version' Nothing@ shows as @null@
instance Show ProfileVersions where
show (ProfileVersions cur sup) = mconcat
[ "version ", showV cur, ": ["
, showVs sup, "]"
]
instance Typeable a => Show (Profile a) where
show (InvalidProfile s) = "InvalidProfile: " <> s
show (Profile pv) =
let p = Proxy :: Proxy a
in mconcat [ "Profile for \"", typeName0 p
, "\" (", show pv, ")"
]
-- | Easy way to get a printable failure/success report
-- of the internal consistency of a SafeJSON instance.
mkProfile :: forall a. SafeJSON a => Proxy a -> Profile a
mkProfile p = case computeConsistency p of
NotConsistent t -> InvalidProfile t
Consistent -> Profile $ ProfileVersions {
profileCurrentVersion = unVersion (version @a),
profileSupportedVersions = availableVersions p
}
data Consistency a = Consistent
| NotConsistent String
checkConsistency :: (SafeJSON a, MonadFail m) => Proxy a -> (ProfileVersions -> m b) -> m b
checkConsistency p m =
case mkProfile p of
InvalidProfile s -> fail s
Profile vs -> m vs
computeConsistency :: forall a. SafeJSON a => Proxy a -> Consistency a
computeConsistency p
-- This checks the chain of versions to not clash or loop,
-- and it verifies only 'Base' or 'Extended Base' kinds can
-- have 'noVersion'
| isObviouslyConsistent (kind @a) = Consistent
| Just s <- invalidChain p = NotConsistent s
| otherwise = Consistent
{-# INLINE computeConsistency #-}
isObviouslyConsistent :: Kind a -> Bool
isObviouslyConsistent Base = True
isObviouslyConsistent _ = False
availableVersions :: forall a. SafeJSON a => Proxy a -> [(Maybe Int32, String)]
availableVersions _ =
worker False (kind @a)
where
worker :: forall b. SafeJSON b => Bool -> Kind b -> [(Maybe Int32, String)]
worker fwd thisKind = case thisKind of
Base -> [tup]
Extends p' -> tup : worker fwd (kindFromProxy p')
Extended k | not fwd -> worker True (getForwardKind k)
Extended k -> worker True k
where Version v = version @b
name = typeName (Proxy @b)
tup = (v, name)
-- TODO: Have this output a custom type to differentiate between bad outcomes.
-- That way the tests can be more reliable. (Did they catch what they were
-- supposed to catch?)
invalidChain :: forall a. SafeJSON a => Proxy a -> Maybe String
invalidChain _ =
worker mempty mempty (kind @a)
where
-- Version set Version set with type name Kind Maybe error
worker :: forall b. SafeJSON b => S.Set (Maybe Int32) -> S.Set (Maybe Int32, String) -> Kind b -> Maybe String
worker vs vSs k
| i `S.member` vs = Just $ mconcat
[ "Double occurence of version number '", showV i
, "' (type: ", typeName p
, "). Looping instances if the previous combination of type and version number are found here: "
, showVs $ S.toList vSs
]
| otherwise = case k of
Base -> Nothing
Extends{} | i == Nothing -> Just $ mconcat
[ typeName p, " has defined 'version = noVersion', "
, " but it's 'kind' definition is not 'base' or 'extended_base'"
]
Extends a_proxy -> worker newVSet newVsSet (kindFromProxy a_proxy)
Extended a_kind -> let v@(Version i') = versionFromKind $ getForwardKind a_kind
tup = (i', typeName (proxyFromVersion v))
in worker (S.insert i' vs) (S.insert tup vSs) a_kind
where Version i = version @b
p = Proxy @b
newVSet = S.insert i vs
newVsSet = S.insert (i, typeName p) vSs
----------------------------------------------------------
-- Conversion functions
----------------------------------------------------------
proxyFromVersion :: Version a -> Proxy a
proxyFromVersion _ = Proxy
kindFromProxy :: SafeJSON a => Proxy a -> Kind a
kindFromProxy _ = kind
versionFromProxy :: SafeJSON a => Proxy a -> Version a
versionFromProxy _ = version
versionFromKind :: SafeJSON a => Kind a -> Version a
versionFromKind _ = version
getForwardKind :: Migrate (Reverse a) => Kind a -> Kind (MigrateFrom (Reverse a))
getForwardKind _ = kind
-- ---------------------- --
-- Defining safeFrom --
-- ---------------------- --
withContained :: (a -> b -> c -> m d) -> a -> b -> c -> Contained (m d)
withContained f name prs = contain . f name prs
-- | Similar to 'Data.Aeson.withObject', but 'contain'ed to be used
-- in 'safeFrom' definitions
--
-- @since 1.0.0
containWithObject :: String -> (Object -> Parser a) -> Value -> Contained (Parser a)
containWithObject = withContained withObject
-- | Similar to 'Data.Aeson.withArray', but 'contain'ed to be used
-- in 'safeFrom' definitions
--
-- @since 1.0.0
containWithArray :: String -> (Array -> Parser a) -> Value -> Contained (Parser a)
containWithArray = withContained withArray
-- | Similar to 'Data.Aeson.withText', but 'contain'ed to be used
-- in 'safeFrom' definitions
--
-- @since 1.0.0
containWithText :: String -> (Text -> Parser a) -> Value -> Contained (Parser a)
containWithText = withContained withText
-- | Similar to 'Data.Aeson.withScientific', but 'contain'ed to be used
-- in 'safeFrom' definitions
--
-- @since 1.0.0
containWithScientific :: String -> (Scientific -> Parser a) -> Value -> Contained (Parser a)
containWithScientific = withContained withScientific
-- | Similar to 'Data.Aeson.withBool', but 'contain'ed to be used
-- in 'safeFrom' definitions
--
-- @since 1.0.0
containWithBool :: String -> (Bool -> Parser a) -> Value -> Contained (Parser a)
containWithBool = withContained withBool
-- | Similar to 'Data.Aeson..:', but uses `safeFromJSON` instead of parseJSON
-- to parse the value in the given field.
--
-- @since 1.0.0
(.:$) :: SafeJSON a => Object -> Text -> Parser a
(.:$) = explicitParseField safeFromJSON
-- | Similar to 'Data.Aeson..:?', but uses `safeFromJSON` instead of parseJSON
-- to maybe parse the value in the given field.
--
-- @since 1.0.0
(.:$?) :: SafeJSON a => Object -> Text -> Parser (Maybe a)
(.:$?) = explicitParseFieldMaybe safeFromJSON
-- | Similar to 'Data.Aeson..:!', but uses `safeFromJSON` instead of parseJSON
-- to maybe parse the value in the given field.
--
-- @since 1.0.0
(.:$!) :: SafeJSON a => Object -> Text -> Parser (Maybe a)
(.:$!) = explicitParseFieldMaybe' safeFromJSON
-- -------------------- --
-- Defining safeTo --
-- -------------------- --
-- | Similarly to 'Data.Aeson..=', but uses 'safeToJSON' instead of toJSON
-- to convert the value in that key-value pair.
--
-- @since 1.0.0
(.=$) :: (SafeJSON a, KeyValue kv) => Text -> a -> kv
name .=$ val = name .= safeToJSON val
-- ---------------------- --
-- SafeJSON Instances --
-- ---------------------- --
#define BASIC_NULLARY(T) \
instance SafeJSON T where { version = noVersion }
BASIC_NULLARY(Void)
BASIC_NULLARY(Bool)
BASIC_NULLARY(Ordering)
BASIC_NULLARY(())
BASIC_NULLARY(Char)
BASIC_NULLARY(Float)
BASIC_NULLARY(Double)
BASIC_NULLARY(Int)
BASIC_NULLARY(Natural)
BASIC_NULLARY(Integer)
BASIC_NULLARY(Int8)
BASIC_NULLARY(Int16)
BASIC_NULLARY(Int32)
BASIC_NULLARY(Int64)
BASIC_NULLARY(Word)
BASIC_NULLARY(Word8)
BASIC_NULLARY(Word16)
BASIC_NULLARY(Word32)
BASIC_NULLARY(Word64)
BASIC_NULLARY(T.Text)
BASIC_NULLARY(LT.Text)
BASIC_NULLARY(DV.Version)
BASIC_NULLARY(Scientific)
BASIC_NULLARY(IntSet)
BASIC_NULLARY(UUID)
BASIC_NULLARY(Value)
instance (FromJSON a, ToJSON a, Integral a) => SafeJSON (Ratio a) where
typeName = typeName1
version = noVersion
instance (HasResolution a) => SafeJSON (Fixed a) where
typeName = typeName1
version = noVersion
instance SafeJSON (Proxy a) where
typeName = typeName1
version = noVersion
instance {-# OVERLAPPING #-} SafeJSON String where
typeName _ = "String"
version = noVersion
-- --------------------------- --
-- SafeJSON Time Instances --
-- --------------------------- --
BASIC_NULLARY(CTime)
BASIC_NULLARY(ZonedTime)
BASIC_NULLARY(LocalTime)
BASIC_NULLARY(TimeOfDay)
BASIC_NULLARY(UTCTime)
BASIC_NULLARY(NominalDiffTime)
BASIC_NULLARY(DiffTime)
BASIC_NULLARY(Day)
BASIC_NULLARY(DotNetTime)
-- ------------------------------------ --
-- More involved SafeJSON instances --
-- ------------------------------------ --
instance SafeJSON a => SafeJSON (Const a b) where
safeFrom val = contain $ Const <$> safeFromJSON val
safeTo (Const a) = contain $ safeToJSON a
typeName = typeName2
version = noVersion
instance SafeJSON a => SafeJSON (Maybe a) where
-- This follows the same 'Null' logic as the aeson library
safeFrom Null = contain $ pure (Nothing :: Maybe a)
safeFrom val = contain $ Just <$> safeFromJSON val
-- Nothing means do whatever Aeson thinks Nothing should be
safeTo Nothing = contain $ toJSON (Nothing :: Maybe Value)
-- If there's something, keep it safe
safeTo (Just a) = contain $ safeToJSON a
typeName = typeName1
version = noVersion
instance (SafeJSON a, SafeJSON b) => SafeJSON (Either a b) where
safeFrom val = contain $ do
eVal <- parseJSON val
case eVal of
Left a -> Left <$> safeFromJSON a
Right b -> Right <$> safeFromJSON b
safeTo (Left a) = contain $ toJSON (Left $ safeToJSON a :: Either Value Void)
safeTo (Right b) = contain $ toJSON (Right $ safeToJSON b :: Either Void Value)
typeName = typeName2
version = noVersion
#define BASIC_UNARY(T) \
instance SafeJSON a => SafeJSON (T a) where { \
safeFrom val = contain $ T <$> safeFromJSON val; \
safeTo (T a) = contain $ safeToJSON a; \
typeName = typeName1; \
version = noVersion }
BASIC_UNARY(Identity)
BASIC_UNARY(First)
BASIC_UNARY(Last)
BASIC_UNARY(Min)
BASIC_UNARY(Max)
BASIC_UNARY(Dual)
fromGenericVector :: (SafeJSON a, VG.Vector v a) => Value -> Contained (Parser (v a))
fromGenericVector val = contain $ do
v <- parseJSON val
VG.convert <$> VG.mapM safeFromJSON (v :: V.Vector Value)
toGenericVector :: (SafeJSON a, VG.Vector v a) => v a -> Contained Value
toGenericVector = contain . toJSON . fmap safeToJSON . VG.toList
instance SafeJSON a => SafeJSON (V.Vector a) where
safeFrom = fromGenericVector
safeTo = toGenericVector
typeName = typeName1
version = noVersion
instance (SafeJSON a, VP.Prim a) => SafeJSON (VP.Vector a) where
safeFrom = fromGenericVector
safeTo = toGenericVector
typeName = typeName1
version = noVersion
instance (SafeJSON a, VS.Storable a) => SafeJSON (VS.Vector a) where
safeFrom = fromGenericVector
safeTo = toGenericVector
typeName = typeName1
version = noVersion
instance (SafeJSON a, VG.Vector VU.Vector a) => SafeJSON (VU.Vector a) where
safeFrom = fromGenericVector
safeTo = toGenericVector
typeName = typeName1
version = noVersion
-- | Lists and any other "container" are seen as only that:
-- a container for 'SafeJSON' values.
--
-- "Containers" are implemented in such a way that when parsing
-- a collection of all migratable versions, the result will be
-- a list of that type where each element has been migrated as
-- appropriate.
instance {-# OVERLAPPABLE #-} SafeJSON a => SafeJSON [a] where
safeFrom val = contain $ do
vs <- parseJSON val
mapM safeFromJSON vs
safeTo as = contain . toJSON $ safeToJSON <$> as
typeName = typeName1
version = noVersion
#define BASIC_UNARY_FUNCTOR(T) \
instance SafeJSON a => SafeJSON (T a) where { \
safeFrom val = contain $ do { \
vs <- parseJSON val; \
mapM safeFromJSON vs }; \
safeTo as = contain . toJSON $ safeToJSON <$> as; \
typeName = typeName1; \
version = noVersion }
BASIC_UNARY_FUNCTOR(NonEmpty)
BASIC_UNARY_FUNCTOR(Seq)
BASIC_UNARY_FUNCTOR(Tree)
instance (SafeJSON a) => SafeJSON (IntMap a) where
safeFrom val = contain $ do
vs <- parseJSON val
IM.fromList <$> mapM safeFromJSON vs
safeTo as = contain . toJSON $ safeToJSON <$> as
typeName = typeName1
version = noVersion
instance (SafeJSON a) => SafeJSON (DList a) where
safeFrom val = contain $ do
vs <- parseJSON val
DList.fromList <$> mapM safeFromJSON vs
safeTo as = contain . toJSON $ safeToJSON <$> as
typeName = typeName1
version = noVersion
instance (SafeJSON a, Ord a) => SafeJSON (S.Set a) where
safeFrom val = contain $ do
vs <- parseJSON val
S.fromList <$> safeFromJSON vs
safeTo as = contain . toJSON $ safeToJSON <$> S.toList as
typeName = typeName1
version = noVersion
instance (Ord k, FromJSONKey k, ToJSONKey k, SafeJSON a) => SafeJSON (Map k a) where
safeFrom val = contain $ do
vs <- parseJSON val
mapM safeFromJSON vs
safeTo as = contain . toJSON $ safeToJSON <$> as
typeName = typeName2
version = noVersion
instance (SafeJSON a, Eq a, Hashable a) => SafeJSON (HS.HashSet a) where
safeFrom val = contain $ do
vs <- parseJSON val
HS.fromList <$> safeFromJSON vs
safeTo as = contain . toJSON $ safeToJSON <$> HS.toList as
typeName = typeName1
version = noVersion
instance (Hashable a, FromJSONKey a, ToJSONKey a, Eq a, SafeJSON b) => SafeJSON (HM.HashMap a b) where
safeFrom val = contain $ do
vs <- parseJSON val
fmap HM.fromList . mapM (mapM safeFromJSON) $ HM.toList vs
safeTo as = contain . toJSON $ safeToJSON <$> as
typeName = typeName2
version = noVersion
instance (SafeJSON a, SafeJSON b) => SafeJSON (a, b) where
safeFrom x = contain $ do
(a',b') <- parseJSON x
a <- safeFromJSON a'
b <- safeFromJSON b'
return (a,b)
safeTo (a,b) = contain $ toJSON (safeToJSON a, safeToJSON b)
typeName = typeName2
version = noVersion
instance (SafeJSON a, SafeJSON b, SafeJSON c) => SafeJSON (a, b, c) where
safeFrom x = contain $ do
(a',b',c') <- parseJSON x
a <- safeFromJSON a'
b <- safeFromJSON b'
c <- safeFromJSON c'
return (a,b,c)
safeTo (a,b,c) = contain $ toJSON (safeToJSON a, safeToJSON b, safeToJSON c)
typeName = typeName3
version = noVersion
instance (SafeJSON a, SafeJSON b, SafeJSON c, SafeJSON d) => SafeJSON (a, b, c, d) where
safeFrom x = contain $ do
(a',b',c',d') <- parseJSON x
a <- safeFromJSON a'
b <- safeFromJSON b'
c <- safeFromJSON c'
d <- safeFromJSON d'
return (a,b,c,d)
safeTo (a,b,c,d) = contain $ toJSON (safeToJSON a, safeToJSON b, safeToJSON c, safeToJSON d)
typeName = typeName4
version = noVersion
instance (SafeJSON a, SafeJSON b, SafeJSON c, SafeJSON d, SafeJSON e) => SafeJSON (a, b, c, d, e) where
safeFrom x = contain $ do
(a',b',c',d',e') <- parseJSON x
a <- safeFromJSON a'
b <- safeFromJSON b'
c <- safeFromJSON c'
d <- safeFromJSON d'
e <- safeFromJSON e'
return (a,b,c,d,e)
safeTo (a,b,c,d,e) = contain $ toJSON (safeToJSON a, safeToJSON b, safeToJSON c, safeToJSON d, safeToJSON e)
typeName = typeName5
version = noVersion