Base.hs

{-# LANGUAGE StandaloneDeriving, DerivingVia, TypeApplications, ScopedTypeVariables, DeriveGeneric, FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
--Serialise instances for ProjectM36.Base data types- orphan instance city
module ProjectM36.Serialise.Base where
import Codec.Winery hiding (Schema)
import Codec.Winery.Internal
import Control.Monad
import ProjectM36.Base
import ProjectM36.MerkleHash
import ProjectM36.Relation
import ProjectM36.Tuple
import ProjectM36.TupleSet as TS
import ProjectM36.DatabaseContext.Types
import ProjectM36.AccessControlList
import ProjectM36.DisconnectedTransaction (CurrentHead)
import ProjectM36.IsomorphicSchema.Types
import ProjectM36.Transaction.Types
import Data.UUID
import Data.Proxy
import Data.Word
import ProjectM36.Attribute as A
import qualified Data.Vector as V
import Data.Time.Calendar (Day,toGregorian,fromGregorian)
import GHC.Generics (Generic)
#if MIN_VERSION_winery(1,4,0)
#else
import qualified Data.List.NonEmpty as NE
#endif

deriving via WineryVariant Atom instance Serialise Atom
deriving via WineryVariant AtomType instance Serialise AtomType
deriving via WineryVariant Attribute instance Serialise Attribute
deriving via WineryVariant RelationTuple instance Serialise RelationTuple
deriving via WineryVariant RelationCardinality instance Serialise RelationCardinality
deriving via WineryVariant (RelationalExprBase a) instance Serialise a => Serialise (RelationalExprBase a)
deriving via WineryVariant (WithNameExprBase a) instance Serialise a => Serialise (WithNameExprBase a)
deriving via WineryVariant Notification instance Serialise Notification
deriving via WineryVariant TypeConstructorDef instance Serialise TypeConstructorDef
deriving via WineryVariant (TypeConstructorBase a) instance Serialise a => Serialise (TypeConstructorBase a)
deriving via WineryVariant DataConstructorDef instance Serialise DataConstructorDef
deriving via WineryVariant DataConstructorDefArg instance Serialise DataConstructorDefArg
deriving via WineryVariant GraphRefTransactionMarker instance Serialise GraphRefTransactionMarker
deriving via WineryVariant SchemaIsomorph instance Serialise SchemaIsomorph
deriving via WineryVariant InclusionDependency instance Serialise InclusionDependency
deriving via WineryVariant (DatabaseContextExprBase a r) instance (Serialise a, Serialise r) => Serialise (DatabaseContextExprBase a r)
deriving via WineryVariant (DatabaseContextIOExprBase a) instance Serialise a => Serialise (DatabaseContextIOExprBase a)
deriving via WineryVariant (RestrictionPredicateExprBase a) instance Serialise a => Serialise (RestrictionPredicateExprBase a)
deriving via WineryVariant TransactionInfo instance Serialise TransactionInfo
deriving via WineryVariant (AtomExprBase a) instance Serialise a => Serialise (AtomExprBase a)
deriving via WineryVariant MerkleHash instance Serialise MerkleHash
deriving via WineryVariant (AttributeExprBase a) instance Serialise a => Serialise (AttributeExprBase a)
deriving via WineryVariant (TupleExprsBase a) instance Serialise a => Serialise (TupleExprsBase a)
deriving via WineryVariant (TupleExprBase a) instance Serialise a => Serialise (TupleExprBase a)
deriving via WineryVariant (AttributeNamesBase a) instance Serialise a => Serialise (AttributeNamesBase a)
deriving via WineryVariant (ExtendTupleExprBase a) instance Serialise a => Serialise (ExtendTupleExprBase a)
deriving via WineryVariant Schema instance Serialise Schema
deriving via WineryVariant MergeStrategy instance Serialise MergeStrategy
deriving via WineryVariant NotificationExpression instance Serialise NotificationExpression
deriving via WineryVariant CurrentHead instance Serialise CurrentHead
-- ACL
deriving via WineryRecord DatabaseContextACL instance Serialise DatabaseContextACL
deriving via WineryRecord RelVarAccessControlList instance Serialise RelVarAccessControlList
deriving via WineryVariant RelVarPermission instance Serialise RelVarPermission

deriving via WineryRecord FunctionAccessControlList instance Serialise FunctionAccessControlList
deriving via WineryVariant FunctionPermission instance Serialise FunctionPermission

deriving via WineryVariant ACLAccessControlList instance Serialise ACLAccessControlList
deriving via WineryVariant ACLPermission instance Serialise ACLPermission

deriving via WineryRecord AlterTransGraphAccessControlList instance Serialise AlterTransGraphAccessControlList
deriving via WineryVariant AlterTransGraphPermission instance Serialise AlterTransGraphPermission

deriving via WineryRecord SchemaAccessControlList instance Serialise SchemaAccessControlList
deriving via WineryVariant AlterSchemaPermission instance Serialise AlterSchemaPermission

deriving via WineryRecord DBCFunctionAccessControlList instance Serialise DBCFunctionAccessControlList
deriving via WineryVariant DBCFunctionPermission instance Serialise DBCFunctionPermission

deriving via WineryVariant (AlterDBCACLExprBase r) instance Serialise r => Serialise (AlterDBCACLExprBase r)

deriving via WineryVariant SomePermission instance Serialise SomePermission

fromWordsTup :: (Word32, Word32, Word32, Word32) -> TransactionId
fromWordsTup (a,b,c,d) = fromWords a b c d

instance Serialise TransactionId where
  schemaGen _ = getSchema (Proxy @(Word32, Word32, Word32, Word32))
  toBuilder uuid = toBuilder (toWords uuid)
  extractor = fromWordsTup <$> extractor
  decodeCurrent = fromWordsTup <$> decodeCurrent

#if MIN_VERSION_winery(1,4,0)
#else
instance Serialise a => Serialise (NE.NonEmpty a) where
  schemaGen _ = SVector <$> getSchema (Proxy @a)
  toBuilder xs = varInt (length xs) <> foldMap toBuilder xs
  extractor = NE.fromList . V.toList <$> extractListBy extractor --use nonempty instead to replace error with winery error
  decodeCurrent = do
    n <- decodeVarInt
    l <- replicateM n decodeCurrent
    pure (NE.fromList l)
#endif

fromGregorianTup :: (Integer, Int, Int) -> Day
fromGregorianTup (a, b, c) = fromGregorian a b c

instance Serialise Day where
  schemaGen _ = getSchema (Proxy @(Integer, Int, Int))
  toBuilder day = toBuilder (toGregorian day)
  extractor = fromGregorianTup <$> extractor
  decodeCurrent = fromGregorianTup <$> decodeCurrent

instance Serialise Attributes where
  schemaGen _ = SVector <$> getSchema (Proxy @Attribute)
  toBuilder attrs = varInt (V.length (attributesVec attrs)) <> foldMap toBuilder (V.toList (attributesVec attrs))
  extractor =
    attributesFromList . V.toList <$> extractListBy extractor

  decodeCurrent = do
    n <- decodeVarInt
    l <- replicateM n decodeCurrent
    pure (A.attributesFromList l)

-- | A special instance of Serialise which cuts down on duplicate attributes- we should only serialise the attributes at the top-level and not duplicate them per tuple.
instance Serialise Relation where
  schemaGen _ = getSchema (Proxy @(Attributes, [V.Vector Atom]))
  toBuilder rel = toBuilder (attributes rel, map tupleAtoms (tuplesList rel))
  extractor = makeRelation <$> extractor
   where
    makeRelation (attrs, atomList) =  Relation attrs (RelationTupleSet (map (RelationTuple attrs) atomList))
  decodeCurrent = do
    (attrs, atomList) <- decodeCurrent
    pure (Relation attrs (RelationTupleSet (map (RelationTuple attrs) atomList)))   

type SlimTupleSet = Either () (Attributes, [V.Vector Atom])

slimTupleSet :: RelationTupleSet -> SlimTupleSet
slimTupleSet tupSet =
  case asList tupSet of
    [] -> Left ()
    tup:tups -> Right (tupleAttributes tup, map tupleAtoms (tup:tups))

-- | restore slimmed tuple set to include single shared attributes list
fattenTupleSet :: SlimTupleSet -> RelationTupleSet
fattenTupleSet Left{} = TS.empty
fattenTupleSet (Right (attrs, vtups)) = RelationTupleSet $ map (RelationTuple attrs) vtups

-- | A special instance of Serialise which cuts down on duplicate attributes- we should only serialise the attributes at the top-level and not duplicate them per tuple. If we have an empty tupleset, we lack all attributes which is fine in this case.
instance Serialise RelationTupleSet where
  schemaGen _ = getSchema (Proxy @SlimTupleSet)
  toBuilder tupSet = toBuilder (slimTupleSet tupSet)
  extractor = fattenTupleSet <$> extractor
  decodeCurrent = fattenTupleSet <$> decodeCurrent

data GraphRefOrUpdate a =
  -- | Use the value from the same field at the transaction marker (no difference).
  GraphRefValue GraphRefTransactionMarker |
  UpdateValue a

-- | Used only for serialization.
data GraphRefDatabaseContext = GraphRefDatabaseContext
  {
    inclusionDependencies :: GraphRefOrUpdate InclusionDependencies,
    relationVariables :: GraphRefOrUpdate RelationVariables,
    atomFunctions :: GraphRefOrUpdate AtomFunctions,
    dbcFunctions :: GraphRefOrUpdate DatabaseContextFunctions,
    notifications :: GraphRefOrUpdate Notifications,
    typeConstructorMapping :: GraphRefOrUpdate TypeConstructorMapping,
    registeredQueries :: GraphRefOrUpdate RegisteredQueries
  } deriving (Generic)