beam-migrate-0.3.1.0: Database/Beam/Migrate/Serialization.hs
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE CPP #-}
-- | Serialization and deserialization helpers for beam data types.
--
-- Used to read and write machine-readable schema descriptions.
module Database.Beam.Migrate.Serialization
( -- * Serialization helpers
-- $serialization
BeamSerializedDataType(..)
, BeamSerializedConstraintDefinition(..)
, BeamSerializedConstraintAttributes(..)
, BeamSerializedConstraint(..)
, BeamSerializedMatchType(..)
, BeamSerializedReferentialAction(..)
, BeamSerializedExpression(..)
, beamSerializeJSON, serializePrecAndDecimal
-- * Deserialization helpers
-- $deserialization
, BeamDeserializers(..)
, beamDeserialize, beamDeserializeMaybe
, beamDeserializer, sql92Deserializers
, sql99DataTypeDeserializers
, sql2003BinaryAndVarBinaryDataTypeDeserializers
, sql2008BigIntDataTypeDeserializers
) where
import Database.Beam.Backend.SQL
import Database.Beam.Migrate.SQL.SQL92
import Control.Applicative
import Control.Monad
import Data.Aeson
import Data.Aeson.Types (Parser)
import qualified Data.Dependent.Map as D
import qualified Data.GADT.Compare as D
import Data.Text (Text, unpack)
import Data.Typeable (Typeable, (:~:)( Refl ), eqT, typeRep, typeOf)
import qualified Data.Vector as V
#if !MIN_VERSION_base(4, 11, 0)
import Data.Semigroup
#endif
-- * Serialization helpers
-- | An 'IsSql92DataTypeSyntax' for JSON. Supports all superclasses of
-- `IsSql92DataTypeSyntax` declared in @beam-core@.
newtype BeamSerializedDataType
= BeamSerializedDataType { fromBeamSerializedDataType :: Value }
deriving (Show, Eq)
instance IsSql92DataTypeSyntax BeamSerializedDataType where
domainType nm = BeamSerializedDataType (object [ "domain" .= nm])
charType prec collation =
BeamSerializedDataType (object [ "char" .= object [ "prec" .= prec
, "collation" .= collation ]])
varCharType prec collation =
BeamSerializedDataType (object [ "varchar" .= object [ "prec" .= prec
, "collation" .= collation ]])
nationalCharType prec =
BeamSerializedDataType (object [ "national-char" .= object [ "prec" .= prec ]])
nationalVarCharType prec =
BeamSerializedDataType (object [ "national-varchar" .= object [ "prec" .= prec ]])
bitType prec =
BeamSerializedDataType (object [ "bit" .= object [ "prec" .= prec ]])
varBitType prec =
BeamSerializedDataType (object [ "varbit" .= object [ "prec" .= prec ]])
numericType precAndDecimal =
BeamSerializedDataType (object [ "numeric" .= serializePrecAndDecimal precAndDecimal ])
decimalType precAndDecimal =
BeamSerializedDataType (object [ "decimal" .= serializePrecAndDecimal precAndDecimal ])
intType = BeamSerializedDataType "int"
smallIntType = BeamSerializedDataType "smallint"
floatType prec =
BeamSerializedDataType (object [ "float" .= object [ "prec" .= prec ] ])
doubleType = BeamSerializedDataType "double"
realType = BeamSerializedDataType "real"
dateType = BeamSerializedDataType "date"
timeType prec withTz =
BeamSerializedDataType (object [ "time" .= object [ "prec" .= prec
, "timezone" .= withTz ]])
timestampType prec withTz =
BeamSerializedDataType (object [ "timestamp" .= object [ "prec" .= prec
, "timezone" .= withTz ]])
instance IsSql99DataTypeSyntax BeamSerializedDataType where
characterLargeObjectType = BeamSerializedDataType "clob"
binaryLargeObjectType = BeamSerializedDataType "blob"
booleanType = BeamSerializedDataType "boolean"
arrayType ty count = BeamSerializedDataType (object [ "array" .= object [ "of" .= ty
, "count" .= count ]])
rowType tys = BeamSerializedDataType (object [ "row" .= tys ])
instance IsSql2003BinaryAndVarBinaryDataTypeSyntax BeamSerializedDataType where
binaryType sz = BeamSerializedDataType (object [ "binary" .= sz ])
varBinaryType sz = BeamSerializedDataType (object [ "varbinary" .= sz ])
instance IsSql2008BigIntDataTypeSyntax BeamSerializedDataType where
bigIntType = BeamSerializedDataType "bigint"
instance ToJSON BeamSerializedDataType where
toJSON = fromBeamSerializedDataType
-- | 'IsSql92ColumnConstraintDefinitionSyntax' type for JSON
newtype BeamSerializedConstraintDefinition
= BeamSerializedConstraintDefinition
{ fromBeamSerializedConstraintDefinition :: Value
} deriving (Show, Eq)
-- | 'IsSql92ConstraintAttributesSyntax' type for JSON
newtype BeamSerializedConstraintAttributes
= BeamSerializedConstraintAttributes
{ fromBeamSerializedConstraintAttributes :: [ Value ]
} deriving (Show, Eq, Monoid, Semigroup)
-- | 'IsSql92ColumnConstraintSyntax' type for JSON
newtype BeamSerializedConstraint
= BeamSerializedConstraint
{ fromBeamSerializedConstraint :: Value
} deriving (Show, Eq)
-- | 'IsSql92MatchTypeSyntax' type for JSON
newtype BeamSerializedMatchType
= BeamSerializedMatchType
{ fromBeamSerializedMatchType :: Value
} deriving (Show, Eq)
-- | 'IsSql92ReferentialActionSyntax' type for JSON
newtype BeamSerializedReferentialAction
= BeamSerializedReferentialAction
{ fromBeamSerializedReferentialAction :: Value
} deriving (Show, Eq)
-- | 'IsSql92ExpressionSyntax' is too complex for us to store in JSON.
-- Additionally, many backends provide substantial amounts of extensions to the
-- syntax that would make storing this highly unfeasible. Expressions are
-- therefore represented as their full text rendering.
--
-- This means that expressions only match as equal if they match /exactly/.
-- While this may seem overly pedantic, it's not much of a concern if your
-- migrations are generated solely by @beam-migrate@. If you've modified the
-- schema yourself, you may have to use 'IsCustomSqlSyntax' to provide an exact
-- expression.
newtype BeamSerializedExpression
= BeamSerializedExpression
{ fromBeamSerializedExpression :: Text
} deriving (Show, Eq)
instance IsSql92ColumnConstraintDefinitionSyntax BeamSerializedConstraintDefinition where
type Sql92ColumnConstraintDefinitionAttributesSyntax BeamSerializedConstraintDefinition =
BeamSerializedConstraintAttributes
type Sql92ColumnConstraintDefinitionConstraintSyntax BeamSerializedConstraintDefinition =
BeamSerializedConstraint
constraintDefinitionSyntax nm constraint attrs =
BeamSerializedConstraintDefinition $
object [ "name" .= nm
, "attributes" .= fmap fromBeamSerializedConstraintAttributes attrs
, "constraint" .= fromBeamSerializedConstraint constraint ]
instance IsSql92ColumnConstraintSyntax BeamSerializedConstraint where
type Sql92ColumnConstraintMatchTypeSyntax BeamSerializedConstraint =
BeamSerializedMatchType
type Sql92ColumnConstraintReferentialActionSyntax BeamSerializedConstraint =
BeamSerializedReferentialAction
type Sql92ColumnConstraintExpressionSyntax BeamSerializedConstraint =
BeamSerializedExpression
notNullConstraintSyntax = BeamSerializedConstraint "not-null"
uniqueColumnConstraintSyntax = BeamSerializedConstraint "unique"
primaryKeyColumnConstraintSyntax = BeamSerializedConstraint "primary-key"
checkColumnConstraintSyntax e = BeamSerializedConstraint (object [ "check-column" .= fromBeamSerializedExpression e])
referencesConstraintSyntax tbl fields matchType onUpdate onDelete =
BeamSerializedConstraint (object [ "references" .=
object [ "table" .= tbl, "fields" .= fields
, "match-type" .= fmap fromBeamSerializedMatchType matchType
, "on-update" .= fmap fromBeamSerializedReferentialAction onUpdate
, "on-delete" .= fmap fromBeamSerializedReferentialAction onDelete ] ])
instance IsSql92MatchTypeSyntax BeamSerializedMatchType where
fullMatchSyntax = BeamSerializedMatchType "full"
partialMatchSyntax = BeamSerializedMatchType "partial"
instance IsSql92ReferentialActionSyntax BeamSerializedReferentialAction where
referentialActionCascadeSyntax = BeamSerializedReferentialAction "cascade"
referentialActionSetNullSyntax = BeamSerializedReferentialAction "set-null"
referentialActionSetDefaultSyntax = BeamSerializedReferentialAction "set-default"
referentialActionNoActionSyntax = BeamSerializedReferentialAction "nothing"
instance IsSql92ConstraintAttributesSyntax BeamSerializedConstraintAttributes where
initiallyDeferredAttributeSyntax = BeamSerializedConstraintAttributes [ "initially-deferred" ]
initiallyImmediateAttributeSyntax = BeamSerializedConstraintAttributes [ "initially-immediate" ]
notDeferrableAttributeSyntax = BeamSerializedConstraintAttributes [ "not-deferrable" ]
deferrableAttributeSyntax = BeamSerializedConstraintAttributes [ "deferrable" ]
-- | Some backends serialize data that can only be read by that backend. If so,
-- they should wrap these data in 'beamSerializeJSON', which provides a standard
-- syntax for specifying backend specific data, as well as which backend the
-- data are valid for.
--
-- The first argument is a string that is unique to a given backend
beamSerializeJSON :: Text -> Value -> Value
beamSerializeJSON backend v =
object [ "be-specific" .= backend
, "be-data" .= v ]
-- | Helper for serializing the precision and decimal count parameters to
-- 'decimalType', etc.
serializePrecAndDecimal :: Maybe (Word, Maybe Word) -> Value
serializePrecAndDecimal Nothing =
object []
serializePrecAndDecimal (Just (prec, Nothing)) =
object [ "prec" .= prec ]
serializePrecAndDecimal (Just (prec, Just decimal)) =
object [ "prec" .= prec
, "decimal" .= decimal ]
-- * Deserialization helpers
-- ** Data types
newtype BeamDeserializer syntax
= BeamDeserializer (forall cmd. BeamDeserializers cmd -> Value -> Parser syntax)
-- | Provides a collection of deserializers from aeson 'Value's for arbitrary
-- types. The @cmd@ type parameter is a phantom type parameter. Notionally, all
-- deserializers within this 'BeamDeserializers' relate to the @cmd@ syntax.
newtype BeamDeserializers cmd
= BeamDeserializers
{ beamArbitraryDeserializers :: D.DMap BeamDeserializerLabel BeamDeserializer
}
instance Semigroup (BeamDeserializer cmd) where
(<>) = mappend
instance Monoid (BeamDeserializer cmd) where
mempty = BeamDeserializer (const (const mzero))
mappend (BeamDeserializer a) (BeamDeserializer b) =
BeamDeserializer $ \d o ->
a d o <|> b d o
instance Semigroup (BeamDeserializers cmd) where
(<>) = mappend
instance Monoid (BeamDeserializers cmd) where
mempty = BeamDeserializers mempty
mappend (BeamDeserializers a) (BeamDeserializers b) =
BeamDeserializers (D.unionWithKey (const mappend) a b)
-- | Helper function to deserialize data from a 'Maybe' 'Value'.
--
-- @
-- beamDeserializeMaybe _ Nothing = pure Nothing
-- beamDeserializeMaybe d (Just v) = Just <$> beamDeserialize d v
-- @
--
beamDeserializeMaybe :: Typeable a
=> BeamDeserializers cmd
-> Maybe Value
-> Parser (Maybe a)
beamDeserializeMaybe _ Nothing = pure Nothing
beamDeserializeMaybe d (Just v) =
Just <$> beamDeserialize d v
-- | Deserialize the requested type from the given deserializers and aeson 'Value'.
beamDeserialize :: forall a cmd. Typeable a
=> BeamDeserializers cmd -> Value
-> Parser a
beamDeserialize allD@(BeamDeserializers d) v =
case D.lookup (BeamDeserializerLabel :: BeamDeserializerLabel a) d of
Nothing -> fail ("beamDeserialize: No deserializer for " ++ show (typeOf (undefined :: a)))
Just (BeamDeserializer doParse) ->
doParse allD v
data BeamDeserializerLabel ty where
BeamDeserializerLabel :: Typeable ty
=> BeamDeserializerLabel ty
instance D.GEq BeamDeserializerLabel where
geq a b =
case D.gcompare a b of
D.GEQ -> Just Refl
_ -> Nothing
instance D.GCompare BeamDeserializerLabel where
gcompare a@(BeamDeserializerLabel :: BeamDeserializerLabel a)
b@(BeamDeserializerLabel :: BeamDeserializerLabel b) =
case eqT of
Just (Refl :: a :~: b)-> D.GEQ
Nothing ->
case compare (typeRep a) (typeRep b) of
LT -> D.GLT
GT -> D.GGT
EQ -> error "Impossible"
beamDeserializer :: Typeable ty
=> (forall cmd'. BeamDeserializers cmd' -> Value -> Parser ty)
-> BeamDeserializers cmd
beamDeserializer parse =
BeamDeserializers (D.singleton BeamDeserializerLabel (BeamDeserializer parse))
-- | Deserializers for SQL92 syntaxes
sql92Deserializers :: forall cmd
. IsSql92DdlCommandSyntax cmd
=> BeamDeserializers cmd
sql92Deserializers = mconcat
[ beamDeserializer deserializeSql92DataType
, beamDeserializer deserializeSql92ConstraintDefinition
, beamDeserializer deserializeSql92Constraint
, beamDeserializer deserializeSql92MatchType
, beamDeserializer deserializeSql92ReferentialAction
, beamDeserializer deserializeSql92Attributes ]
where
parseSub nm o key parse =
withObject (unpack (nm <> "." <> key)) parse =<< o .: key
deserializeSql92DataType :: BeamDeserializers cmd' -> Value
-> Parser (Sql92DdlCommandDataTypeSyntax cmd)
deserializeSql92DataType _ o =
deserializeSql92DataTypeObject o <|>
deserializeSql92DataTypeScalar o
deserializeSql92DataTypeScalar "int" = pure intType
deserializeSql92DataTypeScalar "smallint" = pure smallIntType
deserializeSql92DataTypeScalar "double" = pure dateType
deserializeSql92DataTypeScalar "real" = pure realType
deserializeSql92DataTypeScalar "date" = pure dateType
deserializeSql92DataTypeScalar _ = mzero
deserializeSql92DataTypeObject =
withObject "Sql92DataType" $ \o ->
let (==>) = parseSub "Sql92DataType" o
in (domainType <$> o .: "domain") <|>
("char" ==> \v ->
charType <$> v .: "prec" <*> v .: "collation") <|>
("varchar" ==> \v ->
varCharType <$> v .: "prec" <*> v .: "collation") <|>
("national-char" ==> \v ->
nationalCharType <$> v .: "prec") <|>
("national-varchar" ==> \v ->
nationalVarCharType <$> v .: "prec") <|>
("bit" ==> \v ->
bitType <$> v .: "prec") <|>
("varbit" ==> \v ->
varBitType <$> v .: "prec") <|>
("numeric" ==> \v ->
numericType <$> deserializePrecAndDecimal v) <|>
("decimal" ==> \v ->
decimalType <$> deserializePrecAndDecimal v) <|>
("float" ==> \v ->
floatType <$> v .: "prec") <|>
("time" ==> \v ->
timeType <$> v .: "prec" <*> v .: "timezone") <|>
("timestamp" ==> \v ->
timestampType <$> v .: "prec" <*> v .: "timezone")
deserializePrecAndDecimal o =
Just <$> (((,) <$> o .: "prec" <*> (Just <$> o .: "decimal")) <|>
((,Nothing) <$> o .: "prec")) <|>
pure Nothing
deserializeSql92ConstraintDefinition :: BeamDeserializers cmd' -> Value
-> Parser (Sql92DdlCommandConstraintDefinitionSyntax cmd)
deserializeSql92ConstraintDefinition d =
withObject "Sql92ColumnConstraintDefinition" $ \o ->
constraintDefinitionSyntax <$> o .: "name"
<*> (beamDeserialize d =<< o .: "constraint")
<*> (beamDeserializeMaybe d =<< o .: "attributes")
deserializeSql92Constraint :: BeamDeserializers cmd' -> Value
-> Parser (Sql92DdlCommandColumnConstraintSyntax cmd)
deserializeSql92Constraint d o =
case o of
"not-null" -> pure notNullConstraintSyntax
"unique" -> pure uniqueColumnConstraintSyntax
_ -> withObject "Sql92ColumnConstraint" parseObject o
where
parseObject v =
let (==>) = parseSub "Sql92ColumnConstraint" v
in checkColumnConstraintSyntax <$> (beamDeserialize d =<< v .: "check-column") <|>
("references" ==> \v' ->
referencesConstraintSyntax <$> v' .: "table" <*> v' .: "fields"
<*> (beamDeserializeMaybe d =<< v' .: "match-type")
<*> (beamDeserializeMaybe d =<< v' .: "on-update")
<*> (beamDeserializeMaybe d =<< v' .: "on-delete"))
deserializeSql92MatchType :: BeamDeserializers cmd' -> Value
-> Parser (Sql92DdlCommandMatchTypeSyntax cmd)
deserializeSql92MatchType _ v =
case v of
"full" -> pure fullMatchSyntax
"partial" -> pure partialMatchSyntax
_ -> mzero
deserializeSql92ReferentialAction :: BeamDeserializers cmd' -> Value
-> Parser (Sql92DdlCommandReferentialActionSyntax cmd)
deserializeSql92ReferentialAction _ v =
case v of
"cascade" -> pure referentialActionCascadeSyntax
"set-null" -> pure referentialActionSetNullSyntax
"set-default" -> pure referentialActionSetDefaultSyntax
"nothing" -> pure referentialActionNoActionSyntax
_ -> mzero
deserializeSql92Attributes :: BeamDeserializers cmd' -> Value
-> Parser (Sql92DdlCommandConstraintAttributesSyntax cmd)
deserializeSql92Attributes _ =
withArray "Sql92Attributes" $ \a ->
pure (foldr (\o accum ->
case o of
"initially-deferred" -> initiallyDeferredAttributeSyntax <> accum
"initially-immediate" -> initiallyImmediateAttributeSyntax <> accum
"not-deferrable" -> notDeferrableAttributeSyntax <> accum
"deferrable" -> deferrableAttributeSyntax <> accum
_ -> accum
) mempty a)
-- | Deserializes data types that are instances of 'IsSql99DataTypeSyntax'
sql99DataTypeDeserializers
:: forall cmd
. ( IsSql92DdlCommandSyntax cmd
, IsSql99DataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )
=> BeamDeserializers cmd
sql99DataTypeDeserializers =
beamDeserializer $ \d v ->
fmap (id @(Sql92DdlCommandDataTypeSyntax cmd)) $
case v of
"clob" -> pure characterLargeObjectType
"blob" -> pure binaryLargeObjectType
_ -> withObject "Sql99DataType" (parseObject d) v
where
parseObject d v =
arrayType <$> (beamDeserialize d =<< v .: "of") <*> v .: "count" <|>
rowType <$> (do rowTypes <- v .: "row"
let parseArray a =
forM (V.toList a) $ \a' -> do
(nm, a'') <- parseJSON a'
(nm,) <$> beamDeserialize d a''
withArray "Sql99DataType.rowType" parseArray rowTypes)
-- | Deserialize data types that are instances of 'IsSql2003BinaryAndVarBinaryDataTypeSyntax'
sql2003BinaryAndVarBinaryDataTypeDeserializers
:: forall cmd
. ( IsSql92DdlCommandSyntax cmd
, IsSql2003BinaryAndVarBinaryDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )
=> BeamDeserializers cmd
sql2003BinaryAndVarBinaryDataTypeDeserializers =
beamDeserializer $ \_ v ->
fmap (id @(Sql92DdlCommandDataTypeSyntax cmd)) $
withObject "Sql2003DataType"
(\o -> (binaryType <$> o .: "binary") <|>
(varBinaryType <$> o .: "varbinary"))
v
-- | Deserialize data types that are instance of 'IsSql2008BigIntDataTypeSyntax'
sql2008BigIntDataTypeDeserializers
:: forall cmd
. ( IsSql92DdlCommandSyntax cmd
, IsSql2008BigIntDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )
=> BeamDeserializers cmd
sql2008BigIntDataTypeDeserializers =
beamDeserializer $ \_ v ->
fmap (id @(Sql92DdlCommandDataTypeSyntax cmd)) $
case v of
"bigint" -> pure bigIntType
_ -> fail "Sql2008DataType.bigint: expected 'bigint'"
-- $serialization
-- Below we provide various instances of Beam SQL syntax types that produce an
-- aeson 'Value' that reflects the call tree. This allows us to read back
-- these data types in various syntaxes.
--
-- Because these are formatted as standard beam syntaxes, backends can easily
-- serialize their data to disk. For an example of what we mean by this, see
-- the instance of 'IsSql92DataTypeSyntax' for 'SqliteDataTypeSyntax' in
-- @beam-sqlite@.
-- $deserialization
--
-- Deserialization requires that knowledge of every type of data we can
-- deserialize is stored in one place. While this is not much of an issue when
-- compiling full Haskell applications, due to the type class mechanism,
-- beam-migrate tools load backends dynamically. This means that we need a
-- separate way to discover deserialization instances for types we care about.
--
-- Values of the 'BeamDeserializers' type represent a set of deserializers all
-- related to one kind of command syntax. You can ask for the deserializers to
-- deserialize any type from an aeson 'Value'. The deserialization will
-- succeed only if a deserializer for the requested type exists and the
-- deserializer was able to parse the 'Value'.
--
-- 'BeamDeserializers' compose monoidally. Thus, you can extend any
-- 'BeamDeserializers' with your own custom deserializers, by 'mappend'ing it
-- with a new 'BeamDeserializers', created by calling 'beamDeserializer'.