project-m36 0.8 → 0.8.1
raw patch · 31 files changed
+940/−109 lines, 31 filesdep +text-manipulatedep ~basedep ~ghcnew-component:exe:Example-DerivingCustomTupleablePVP ok
version bump matches the API change (PVP)
Dependencies added: text-manipulate
Dependency ranges changed: base, ghc
API changes (from Hackage documentation)
Files
- Changelog.markdown +4/−0
- README.markdown +8/−0
- examples/DerivingCustomTupleable.hs +52/−0
- project-m36.cabal +17/−5
- src/bin/ProjectM36/Client/Json.hs +3/−0
- src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs +10/−0
- src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs +11/−2
- src/bin/TutorialD/tutd.hs +9/−0
- src/lib/ProjectM36/AtomFunction.hs +12/−1
- src/lib/ProjectM36/Base.hs +3/−1
- src/lib/ProjectM36/Client.hs +28/−10
- src/lib/ProjectM36/DatabaseContext.hs +15/−1
- src/lib/ProjectM36/DatabaseContextFunction.hs +11/−1
- src/lib/ProjectM36/Error.hs +3/−0
- src/lib/ProjectM36/MerkleHash.hs +10/−0
- src/lib/ProjectM36/Relation/Show/Term.hs +3/−0
- src/lib/ProjectM36/RelationalExpression.hs +28/−11
- src/lib/ProjectM36/ScriptSession.hs +11/−2
- src/lib/ProjectM36/Server.hs +1/−0
- src/lib/ProjectM36/Server/EntryPoints.hs +4/−0
- src/lib/ProjectM36/Server/ParseArgs.hs +7/−1
- src/lib/ProjectM36/Server/RemoteCallTypes.hs +3/−0
- src/lib/ProjectM36/Transaction.hs +9/−4
- src/lib/ProjectM36/TransactionGraph.hs +73/−14
- src/lib/ProjectM36/TransactionInfo.hs +5/−3
- src/lib/ProjectM36/Tupleable.hs +102/−26
- src/lib/ProjectM36/Tupleable/Deriving.hs +229/−0
- test/Relation/Tupleable.hs +170/−4
- test/TransactionGraph/Merge.hs +25/−15
- test/TransactionGraph/Persist.hs +64/−7
- test/TutorialD/Interpreter.hs +10/−1
Changelog.markdown view
@@ -1,3 +1,7 @@+# 2020-10-05 (v0.8.1)++* support GHC 8.10+ # 2020-05-25 (v0.8) * refactor backend to maximize laziness: [An Architecture for Data Independence](docs/data_independence.markdown)
README.markdown view
@@ -6,6 +6,7 @@ [](http://packdeps.haskellers.com/feed?needle=project-m36) [](https://travis-ci.org/agentm/project-m36) [](https://ci.appveyor.com/project/agentm/project-m36)+[](https://github.com/agentm/project-m36/actions?query=workflow%3ACI) *Software can always be made faster, but rarely can it be made more correct.*@@ -14,6 +15,12 @@ Project:M36 implements a relational algebra engine as inspired by the writings of Chris Date. +## Quick Install++Project:M36 can be downloaded and run via docker, which supports Windows 10, macOS, and Linux.++Run `docker run -it projectm36/project-m36 tutd` to start the TutorialD command line interface.+ ## Description Unlike most database management systems (DBMS), Project:M36 is opinionated software which adheres strictly to the mathematics of the relational algebra. The purpose of this adherence is to prove that software which implements mathematically-sound design principles reaps benefits in the form of code clarity, consistency, performance, and future-proofing.@@ -78,6 +85,7 @@ 1. [Isomorphic Schemas](docs/isomorphic_schemas.markdown) 1. [Replication](docs/replication.markdown) 1. [Basic Operator Benchmarks](https://rawgit.com/agentm/project-m36/master/docs/basic_benchmarks.html)+1. [Merkle Transaction Hashes](docs/merkle_transaction_graph.markdown) ### Integrations
+ examples/DerivingCustomTupleable.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DeriveGeneric, DerivingVia, GeneralizedNewtypeDeriving, TypeOperators, DataKinds, OverloadedStrings #-}++import ProjectM36.Tupleable.Deriving+import ProjectM36.Atomable (Atomable)+import Control.DeepSeq (NFData)+import Data.Binary (Binary)+import Data.Text (Text)+import GHC.Generics (Generic)++newtype BlogId = BlogId { getBlogId :: Int }+ deriving stock (Eq, Ord, Show, Generic)+ deriving newtype (Num)++instance NFData BlogId+instance Binary BlogId+instance Atomable BlogId++data Blog = Blog+ { blogId :: BlogId+ , blogTitle :: Text+ , blogAuthorName :: Text+ }+ deriving stock (Show, Generic)+ deriving (Tupleable)+ via Codec (Field (DropPrefix "blog" >>> CamelCase)) Blog++data Comment = Comment+ { commentAuthorName :: Text+ , commentComment :: Text+ , commentFor :: BlogId+ }+ deriving stock (Show, Generic)+ deriving (Tupleable)+ via Codec (Field (DropPrefix "comment" >>> CamelCase)) Comment++main :: IO ()+main = do+ let exampleBlog = Blog+ { blogId = 0+ , blogTitle = "Cat Pics"+ , blogAuthorName = "Alice"+ }+ exampleComment = Comment+ { commentAuthorName = "Bob"+ , commentComment = "great"+ , commentFor = 0+ }+ print exampleBlog+ print (toTuple exampleBlog)+ putStrLn ""+ print exampleComment+ print (toTuple exampleComment)
project-m36.cabal view
@@ -1,5 +1,5 @@ Name: project-m36-Version: 0.8+Version: 0.8.1 License: PublicDomain Build-Type: Simple Homepage: https://github.com/agentm/project-m36@@ -34,9 +34,9 @@ Default: True Library- Build-Depends: base>=4.8 && < 4.14, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, binary, filepath, zlib, directory, vector-binary-instances, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, network-transport, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, distributed-process-client-server >= 0.2.3, distributed-process >= 0.7.4, distributed-process-extras >= 0.3.2, distributed-process-async >= 0.2.4.1, network-transport-tcp >= 0.6.0, network-transport, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256+ Build-Depends: base>=4.8 && < 4.15, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, binary, filepath, zlib, directory, vector-binary-instances, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, network-transport, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, distributed-process-client-server >= 0.2.3, distributed-process >= 0.7.4, distributed-process-extras >= 0.3.2, distributed-process-async >= 0.2.4.1, network-transport-tcp >= 0.6.0, network-transport, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.3 if flag(haskell-scripting)- Build-Depends: ghc >= 8.2 && < 8.9+ Build-Depends: ghc >= 8.2 && < 8.11 CPP-Options: -DPM36_HASKELL_SCRIPTING if impl(ghc>= 8) && flag(haskell-scripting) build-depends:@@ -79,6 +79,7 @@ ProjectM36.Relation.Parse.CSV, ProjectM36.IsomorphicSchema, ProjectM36.InclusionDependency,+ ProjectM36.MerkleHash, ProjectM36.Client, ProjectM36.Client.Simple, ProjectM36.Persist,@@ -88,6 +89,7 @@ ProjectM36.AtomFunctions.Primitive, ProjectM36.Atomable, ProjectM36.Tupleable,+ ProjectM36.Tupleable.Deriving, ProjectM36.DataConstructorDef, ProjectM36.DataTypes.Basic, ProjectM36.DataTypes.Sorting,@@ -138,7 +140,7 @@ Executable tutd if flag(haskell-scripting)- Build-Depends: ghc >= 8.2 && < 8.9+ Build-Depends: ghc >= 8.2 && < 8.11 Build-Depends: base >=4.8 && <5.0, ghc-paths, project-m36,@@ -203,7 +205,7 @@ Executable project-m36-server if flag(haskell-scripting)- Build-Depends: ghc >= 8.2 && < 8.9+ Build-Depends: ghc >= 8.2 && < 8.11 Build-Depends: base, ghc-paths, project-m36,@@ -407,6 +409,16 @@ Default-Extensions: OverloadedStrings Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36 Main-Is: examples/CustomTupleable.hs+ GHC-Options: -Wall -threaded++Executable Example-DerivingCustomTupleable+ if impl(ghc>=8.6)+ Buildable: True+ else+ Buildable: False+ Default-Language: Haskell2010+ Build-Depends: base, text, deepseq, binary, project-m36+ Main-Is: examples/DerivingCustomTupleable.hs GHC-Options: -Wall -threaded Test-Suite test-scripts
src/bin/ProjectM36/Client/Json.hs view
@@ -3,6 +3,7 @@ import Data.Aeson import ProjectM36.Server.RemoteCallTypes.Json () import ProjectM36.Client+import ProjectM36.TransactionGraph import Control.Exception (IOException) instance ToJSON EvaluatedNotification@@ -12,3 +13,5 @@ instance ToJSON IOException where toJSON err = object ["IOException" .= show err]++instance ToJSON MerkleValidationError
src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs view
@@ -10,6 +10,7 @@ import ProjectM36.Error import ProjectM36.IsomorphicSchema import ProjectM36.Server.RemoteCallTypes+import ProjectM36.MerkleHash import Data.Aeson import Data.ByteString.Base64 as B64@@ -131,6 +132,15 @@ instance ToJSON ScriptCompilationError instance FromJSON ScriptCompilationError++instance ToJSON MerkleHash where+ toJSON h = object [ "merklehash" .= decodeUtf8 (B64.encode (_unMerkleHash h))]+instance FromJSON MerkleHash where+ parseJSON = withObject "merklehash" $ \o -> do+ b64bs <- encodeUtf8 <$> o .: "merklehash"+ case B64.decode b64bs of+ Left err -> fail ("Failed to parse merkle hash: " ++ err)+ Right bs -> pure (MerkleHash bs) instance ToJSON RelationalError instance FromJSON RelationalError
src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs view
@@ -2,8 +2,9 @@ module TutorialD.Interpreter.TransactionGraphOperator where import TutorialD.Interpreter.Base import ProjectM36.TransactionGraph hiding (autoMergeToHead)-import ProjectM36.Client+import ProjectM36.Client as C import ProjectM36.Base+import ProjectM36.Relation (relationTrue) import Data.Functor data ConvenienceTransactionGraphOperator = AutoMergeToHead MergeStrategy HeadName@@ -71,6 +72,9 @@ reservedOp ":mergetrans" MergeTransactions <$> mergeTransactionStrategyP <*> identifier <*> identifier +validateMerkleHashesP :: Parser ROTransactionGraphOperator+validateMerkleHashesP = reservedOp ":validatemerklehashes" $> ValidateMerkleHashes+ transactionGraphOpP :: Parser TransactionGraphOperator transactionGraphOpP = jumpToHeadP@@ -83,7 +87,7 @@ <|> mergeTransactionsP roTransactionGraphOpP :: Parser ROTransactionGraphOperator-roTransactionGraphOpP = showGraphP+roTransactionGraphOpP = showGraphP <|> validateMerkleHashesP @@ -101,6 +105,11 @@ evalROGraphOp :: SessionId -> Connection -> ROTransactionGraphOperator -> IO (Either RelationalError Relation) evalROGraphOp sessionId conn ShowGraph = transactionGraphAsRelation sessionId conn+evalROGraphOp sessionId conn ValidateMerkleHashes = do+ eVal <- C.validateMerkleHashes sessionId conn+ case eVal of+ Left err -> pure (Left err)+ Right _ -> pure (Right relationTrue) evalConvenienceGraphOp :: SessionId -> Connection -> ConvenienceTransactionGraphOperator -> IO (Either RelationalError ()) evalConvenienceGraphOp sessionId conn (AutoMergeToHead strat head') = autoMergeToHead sessionId conn strat head'
src/bin/TutorialD/tutd.hs view
@@ -5,8 +5,10 @@ import ProjectM36.Server.ParseArgs import ProjectM36.Server import System.IO+import GHC.IO.Encoding import Options.Applicative import System.Exit+import Control.Monad #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif@@ -86,8 +88,15 @@ putStrLn "A full tutorial is available at:" putStrLn "https://github.com/agentm/project-m36/blob/master/docs/tutd_tutorial.markdown" +-- | If the locale is set to ASCII, upgrade it to UTF-8 because tutd outputs UTF-8-encoded attributes. This is especially important in light docker images where the locale data may be missing.+setLocaleIfNecessary :: IO ()+setLocaleIfNecessary = do+ l <- getLocaleEncoding+ when (textEncodingName l == "ASCII") (setLocaleEncoding utf8)+ main :: IO () main = do+ setLocaleIfNecessary interpreterConfig <- execParser opts let connInfo = connectionInfoForConfig interpreterConfig fscheck <- checkFSType (checkFSForConfig interpreterConfig) (fromMaybe NoPersistence (persistenceStrategyForConfig interpreterConfig))
src/lib/ProjectM36/AtomFunction.hs view
@@ -9,7 +9,8 @@ import qualified ProjectM36.Attribute as A import qualified Data.HashSet as HS import qualified Data.Text as T-+import qualified Data.ByteString.Lazy as BL+import Data.Binary as B foldAtomFuncType :: AtomType -> AtomType -> [AtomType] --the underscore in the attribute name means that any attributes are acceptable@@ -87,3 +88,13 @@ atomFuncToTuple aFunc = [TextAtom (atomFuncName aFunc), TextAtom (atomFuncTypeToText aFunc)] atomFuncTypeToText aFunc = T.intercalate " -> " (map prettyAtomType (atomFuncType aFunc))++--for calculating the merkle hash+hashBytes :: AtomFunction -> BL.ByteString+hashBytes func = mconcat [B.encode (atomFuncName func),+ B.encode (atomFuncType func),+ bodyBin+ ]+ where+ bodyBin = case atomFuncBody func of+ AtomFunctionBody mScript _ -> B.encode mScript
src/lib/ProjectM36/Base.hs view
@@ -4,6 +4,7 @@ module ProjectM36.Base where import ProjectM36.DatabaseContextFunctionError import ProjectM36.AtomFunctionError+import ProjectM36.MerkleHash import qualified Data.Map as M import qualified Data.HashSet as HS@@ -413,7 +414,8 @@ -- The `TransactionDiff`s represent child/edge relationships to previous transactions (branches or continuations of the same branch). data TransactionInfo = TransactionInfo { parents :: TransactionParents,- stamp :: UTCTime+ stamp :: UTCTime,+ merkleHash :: MerkleHash } deriving (Show, Generic) type TransactionParents = NE.NonEmpty TransactionId
src/lib/ProjectM36/Client.hs view
@@ -80,6 +80,7 @@ databaseContextExprForUniqueKey, databaseContextExprForForeignKey, createScriptedAtomFunction,+ ProjectM36.Client.validateMerkleHashes, AttributeExprBase(..), TypeConstructorBase(..), TypeConstructorDef(..),@@ -118,7 +119,7 @@ import qualified ProjectM36.RelationalExpression as RE import ProjectM36.DatabaseContext (basicDatabaseContext) import qualified ProjectM36.TransactionGraph as Graph-import ProjectM36.TransactionGraph+import ProjectM36.TransactionGraph as TG import qualified ProjectM36.Transaction as Trans import ProjectM36.TransactionGraph.Persist import ProjectM36.Attribute@@ -265,6 +266,7 @@ data ConnectionError = SetupDatabaseDirectoryError PersistenceError | IOExceptionError IOException | NoSuchDatabaseByNameError DatabaseName |+ DatabaseValidationError [MerkleValidationError] | LoginError deriving (Show, Eq, Generic) @@ -379,12 +381,15 @@ case graph of Left err' -> return $ Left (SetupDatabaseDirectoryError err') Right graph' -> do- tvarGraph <- newTVarIO graph'- sessions <- StmMap.newIO- clientNodes <- StmSet.newIO- (localNode, transport) <- createLocalNode- lockMVar <- newMVar digest- let conn = InProcessConnection InProcessConnectionConf {+ case TG.validateMerkleHashes graph' of+ Left merkleErrs -> pure (Left (DatabaseValidationError merkleErrs))+ Right _ -> do+ tvarGraph <- newTVarIO graph'+ sessions <- StmMap.newIO+ clientNodes <- StmSet.newIO+ (localNode, transport) <- createLocalNode+ lockMVar <- newMVar digest+ let conn = InProcessConnection InProcessConnectionConf { ipPersistenceStrategy = strat, ipClientNodes = clientNodes, ipSessions = sessions,@@ -395,9 +400,9 @@ ipLocks = Just (lockFileH, lockMVar) } - notificationPid <- startNotificationListener localNode notificationCallback - addClientNode conn notificationPid- pure (Right conn)+ notificationPid <- startNotificationListener localNode notificationCallback+ addClientNode conn notificationPid+ pure (Right conn) -- | Create a new session at the transaction id and return the session's Id. createSessionAtCommit :: Connection -> TransactionId -> IO (Either RelationalError SessionId)@@ -1205,3 +1210,16 @@ pure (Right dFrame'') executeDataFrameExpr sessionId conn@(RemoteProcessConnection _) dfExpr = remoteCall conn (ExecuteDataFrameExpr sessionId dfExpr) +validateMerkleHashes :: SessionId -> Connection -> IO (Either RelationalError ())+validateMerkleHashes sessionId (InProcessConnection conf) = do+ let sessions = ipSessions conf+ atomically $ do+ eSession <- sessionForSessionId sessionId sessions+ case eSession of+ Left err -> pure (Left err)+ Right _ -> do+ graph <- readTVar (ipTransactionGraph conf)+ case Graph.validateMerkleHashes graph of+ Left merkleErrs -> pure $ Left $ someErrors (map (\(MerkleValidationError tid expected actual) -> MerkleHashValidationError tid expected actual) merkleErrs)+ Right () -> pure (Right ())+validateMerkleHashes sessionId conn@RemoteProcessConnection{} = remoteCall conn (ExecuteValidateMerkleHashes sessionId)
src/lib/ProjectM36/DatabaseContext.hs view
@@ -5,8 +5,11 @@ import qualified Data.HashSet as HS import ProjectM36.DataTypes.Basic import ProjectM36.AtomFunctions.Basic-import ProjectM36.DatabaseContextFunction import ProjectM36.Relation+import qualified Data.ByteString.Lazy as BL+import Data.Binary as B+import ProjectM36.AtomFunction as AF+import ProjectM36.DatabaseContextFunction as DBCF empty :: DatabaseContext empty = DatabaseContext { inclusionDependencies = M.empty, @@ -38,3 +41,14 @@ notifications = M.empty, typeConstructorMapping = basicTypeConstructorMapping }++--for building the Merkle hash+hashBytes :: DatabaseContext -> BL.ByteString+hashBytes ctx = mconcat [incDeps, rvs, atomFs, dbcFs, nots, tConsMap]+ where+ incDeps = B.encode (inclusionDependencies ctx)+ rvs = B.encode (relationVariables ctx)+ atomFs = HS.foldr (mappend . AF.hashBytes) mempty (atomFunctions ctx)+ dbcFs = HS.foldr (mappend . DBCF.hashBytes) mempty (dbcFunctions ctx)+ nots = B.encode (notifications ctx)+ tConsMap = B.encode (typeConstructorMapping ctx)
src/lib/ProjectM36/DatabaseContextFunction.hs view
@@ -10,6 +10,8 @@ import qualified Data.Map as M import ProjectM36.ScriptSession import qualified Data.Text as T+import qualified Data.ByteString.Lazy as BL+import Data.Binary as B emptyDatabaseContextFunction :: DatabaseContextFunctionName -> DatabaseContextFunction emptyDatabaseContextFunction name = DatabaseContextFunction { @@ -77,4 +79,12 @@ dbcFuncToTuple func = [TextAtom (dbcFuncName func), TextAtom (dbcTextType (dbcFuncType func))] dbcTextType typ = T.intercalate " -> " (map prettyAtomType typ ++ ["DatabaseContext", "DatabaseContext"])- ++-- for merkle hash +hashBytes :: DatabaseContextFunction -> BL.ByteString+hashBytes func = mconcat [fname, ftype, fbody]+ where+ fname = B.encode (dbcFuncName func)+ ftype = B.encode (dbcFuncType func)+ fbody = case dbcFuncBody func of+ DatabaseContextFunctionBody mBody _ -> B.encode mBody
src/lib/ProjectM36/Error.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module ProjectM36.Error where import ProjectM36.Base+import ProjectM36.MerkleHash import ProjectM36.DatabaseContextFunctionError import ProjectM36.AtomFunctionError import qualified Data.Set as S@@ -101,6 +102,8 @@ | NoUncommittedContextInEvalError | TupleExprsReferenceMultipleMarkersError++ | MerkleHashValidationError TransactionId MerkleHash MerkleHash | MultipleErrors [RelationalError] deriving (Show,Eq,Generic,Binary,Typeable, NFData)
+ src/lib/ProjectM36/MerkleHash.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric #-}+module ProjectM36.MerkleHash where+import Data.ByteString (ByteString)+import GHC.Generics+import Data.Binary (Binary)+import Control.DeepSeq (NFData)++newtype MerkleHash = MerkleHash { _unMerkleHash :: ByteString }+ deriving (Show, Eq, Binary, Generic, Monoid, Semigroup, NFData)+
src/lib/ProjectM36/Relation/Show/Term.hs view
@@ -9,6 +9,8 @@ import qualified Data.List as L import qualified Data.Text as T import Control.Arrow hiding (left)+import Data.ByteString.Base64 as B64+import qualified Data.Text.Encoding as TE #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif@@ -97,6 +99,7 @@ showAtom _ (RelationAtom rel) = renderTable $ relationAsTable rel showAtom level (ConstructedAtom dConsName _ atoms) = showParens (level >= 1 && not (null atoms)) $ T.concat (L.intersperse " " (dConsName : map (showAtom 1) atoms)) showAtom _ (TextAtom t) = "\"" <> t <> "\""+showAtom _ (ByteStringAtom bs) = TE.decodeUtf8 (B64.encode bs) showAtom _ atom = atomToText atom renderTable :: Table -> StringType
src/lib/ProjectM36/RelationalExpression.hs view
@@ -741,6 +741,7 @@ Right dbcListFunc -> let newContext = currentContext { dbcFunctions = mergedFuncs } mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc) in putDBCIOContext newContext+#endif evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs range) = do --Define currentContext <- getDBCIOContext@@ -771,7 +772,7 @@ case runDatabaseContextEvalMonad currentContext evalEnv (setRelVar relVarName (ExistingRelation rel)) of Left err -> pure (Left err) Right dbstate' -> putDBCIOContext (dbc_context dbstate')-#endif+ {- updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> TransactionGraph -> RelationTuple -> Either RelationalError RelationTuple updateTupleWithAtomExprs exprMap context graph tupIn = do@@ -793,7 +794,11 @@ tempStamp = UTCTime { utctDay = fromGregorian 2000 1 1, utctDayTime = secondsToDiffTime 0 } tempSchemas = Schemas context M.empty- tempTrans = Transaction U.nil (TransactionInfo (transId NE.:| []) tempStamp) tempSchemas+ tempTrans = Transaction U.nil tempTransInfo tempSchemas+ tempTransInfo = TransactionInfo { parents = transId NE.:| [],+ stamp = tempStamp,+ merkleHash = mempty+ } deps = inclusionDependencies context -- no optimization available here, really? perhaps the optimizer should be passed down to here or the eval function should be passed through the environment@@ -1150,15 +1155,27 @@ [] -> pure emptyAttributes (headTuple:tailTuples) -> do --gather up resolved atom types or throw an error if an attribute cannot be made concrete from the inferred types- this could still fail if the type cannot be inferred (e.g. from [Nothing, Nothing])- let mostResolvedTypes =- foldr (\tup acc ->- fmap (\(tupAttr,accAttr) -> --if the attribute is a constructedatomtype, we can recurse into it to potentially resolve type variables- if isResolvedAttribute accAttr then- accAttr- else- case resolveAttributes accAttr tupAttr of- Left _ -> accAttr- Right val -> val) (zip (V.toList $ tupleAttributes tup) acc)) (V.toList $ tupleAttributes headTuple) tailTuples+ let + processTupleAttrs (tupAttr, accAttr) =+ --if the attribute is a constructedatomtype, we can recurse into it to potentially resolve type variables + if isResolvedAttribute accAttr && tupAttr == accAttr then+ pure accAttr+ else+ lift $ except $ resolveAttributes accAttr tupAttr + mostResolvedTypes <-+ foldM (\acc tup -> do+ let zipped = zip (V.toList $ tupleAttributes tup) acc+ accNames = S.fromList $ map A.attributeName acc+ tupNames = A.attributeNameSet (tupleAttributes tup)+ attrNamesDiff = S.union (S.difference accNames tupNames) (S.difference tupNames accNames)+ unless (null attrNamesDiff) (throwError (AttributeNamesMismatchError attrNamesDiff))+ nextTupleAttrs <- mapM processTupleAttrs zipped+ let diff = A.attributesDifference (A.attributesFromList nextTupleAttrs) (A.attributesFromList acc)+ if diff == A.emptyAttributes then+ pure nextTupleAttrs+ else+ throwError (TupleAttributeTypeMismatchError diff)+ ) (V.toList $ tupleAttributes headTuple) tailTuples pure (A.attributesFromList mostResolvedTypes) --strategy: if all the tuple expr transaction markers refer to one location, then we can pass the type constructor mapping from that location, otherwise, we cannot assume that the types are the same tConsMap <- case singularTransactions tupleExprL of
src/lib/ProjectM36/ScriptSession.hs view
@@ -18,6 +18,7 @@ import Data.Text (Text, unpack) import Data.Maybe import GHC.Paths (libdir)+import System.Environment #if __GLASGOW_HASKELL__ >= 800 import GHC.LanguageExtensions import GHCi.ObjLink@@ -78,6 +79,8 @@ handleGhcException excHandler $ runGhc (Just libdir) $ do dflags <- getSessionDynFlags let ghcVersion = projectVersion dflags+ -- get nix packages dir, if available+ mNixLibDir <- liftIO $ lookupEnv "NIX_GHC_LIBDIR" sandboxPkgPaths <- liftIO $ concat <$> mapM glob [ --"./dist-newstyle/packagedb/ghc-" ++ ghcVersion, --rely on cabal 3's ghc.environment install: "cabal install --lib project-m36"@@ -89,7 +92,7 @@ --homeDir </> ".cabal/store/ghc-" ++ ghcVersion ++ "/package.db" ] - let localPkgPaths = map PkgConfFile (ghcPkgPaths ++ sandboxPkgPaths)+ let localPkgPaths = map PkgConfFile (ghcPkgPaths ++ sandboxPkgPaths ++ maybeToList mNixLibDir) let dflags' = applyGopts . applyXopts $ dflags { hscTarget = HscInterpreted , ghcLink = LinkInMemory,@@ -144,7 +147,9 @@ ideclSourceSrc = Nothing, #endif -#if __GLASGOW_HASKELL__ >= 806+#if __GLASGOW_HASKELL__ >= 810+ ideclExt = noExtField,+#elif __GLASGOW_HASKELL__ >= 806 ideclExt = NoExt, #endif ideclName = noLoc mn,@@ -152,7 +157,11 @@ ideclSource = False, ideclSafe = True, ideclImplicit = False,+#if __GLASGOW_HASKELL__ >= 810+ ideclQualified = if isJust mQual then QualifiedPre else NotQualified,+#else ideclQualified = isJust mQual,+#endif ideclAs = mQual, ideclHiding = Nothing }
src/lib/ProjectM36/Server.hs view
@@ -53,6 +53,7 @@ handleCall (\conn (RetrieveSessionIsDirty sessionId) -> handleRetrieveSessionIsDirty ti sessionId conn), handleCall (\conn (ExecuteAutoMergeToHead sessionId strat headName') -> handleExecuteAutoMergeToHead ti sessionId conn strat headName'), handleCall (\conn (RetrieveTypeConstructorMapping sessionId) -> handleRetrieveTypeConstructorMapping ti sessionId conn),+ handleCall (\conn (ExecuteValidateMerkleHashes sessionId) -> handleValidateMerkleHashes ti sessionId conn), handleCall (\conn Logout -> handleLogout ti conn) ] ++ testModeHandlers, unhandledMessagePolicy = Terminate
src/lib/ProjectM36/Server/EntryPoints.hs view
@@ -172,3 +172,7 @@ ret <- timeoutOrDie ti (C.typeConstructorMapping sessionId conn) reply ret conn +handleValidateMerkleHashes :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError ())+handleValidateMerkleHashes ti sessionId conn = do+ ret <- timeoutOrDie ti (C.validateMerkleHashes sessionId conn)+ reply ret conn
src/lib/ProjectM36/Server/ParseArgs.hs view
@@ -73,7 +73,13 @@ helpOption :: Parser (a -> a)-helpOption = abortOption ShowHelpText $ mconcat+helpOption = abortOption helpText $ mconcat [ long "help" , help "Show this help text" , hidden ]+ where+#if MIN_VERSION_optparse_applicative(0,16,0)+ helpText = ShowHelpText Nothing+#else + helpText = ShowHelpText+#endif
src/lib/ProjectM36/Server/RemoteCallTypes.hs view
@@ -69,3 +69,6 @@ deriving (Binary, Generic) data RetrieveTypeConstructorMapping = RetrieveTypeConstructorMapping SessionId deriving (Binary, Generic)++data ExecuteValidateMerkleHashes = ExecuteValidateMerkleHashes SessionId+ deriving (Binary, Generic)
src/lib/ProjectM36/Transaction.hs view
@@ -17,11 +17,10 @@ -- | Return the same transaction but referencing only the specific child transactions. This is useful when traversing a graph and returning a subgraph. This doesn't filter parent transactions because it assumes a head-to-root traversal. filterTransactionInfoTransactions :: S.Set TransactionId -> TransactionInfo -> TransactionInfo filterTransactionInfoTransactions filterIds tinfo =- TransactionInfo { parents = case+ tinfo { parents = case NE.filter (`S.member` filterIds) (parents tinfo) of [] -> rootParent- xs -> NE.fromList xs,- stamp = stamp tinfo }+ xs -> NE.fromList xs} filterParent :: TransactionId -> S.Set TransactionId -> TransactionId filterParent parentId validIds = if S.member parentId validIds then parentId else U.nil@@ -43,7 +42,13 @@ subschemas (Transaction _ _ (Schemas _ sschemas)) = sschemas fresh :: TransactionId -> UTCTime -> Schemas -> Transaction-fresh freshId stamp' = Transaction freshId (TransactionInfo rootParent stamp')+fresh freshId stamp' = Transaction freshId tinfo+ where+ tinfo = TransactionInfo {parents = rootParent,+ stamp = stamp',+ merkleHash = mempty+ } timestamp :: Transaction -> UTCTime timestamp (Transaction _ tinfo _) = stamp tinfo+
src/lib/ProjectM36/TransactionGraph.hs view
@@ -9,6 +9,7 @@ import ProjectM36.Tuple import ProjectM36.RelationalExpression import ProjectM36.TransactionGraph.Merge+import ProjectM36.MerkleHash import qualified ProjectM36.DisconnectedTransaction as Discon import qualified ProjectM36.Attribute as A @@ -22,7 +23,7 @@ import Data.Time.Clock import qualified Data.Text as T import GHC.Generics-import Data.Binary+import Data.Binary as B import Data.Either (lefts, rights, isRight) #if __GLASGOW_HASKELL__ < 804 import Data.Monoid@@ -30,6 +31,9 @@ import Control.Arrow import Data.Maybe import Data.UUID.V4+import qualified Data.ByteString.Lazy as BL+import ProjectM36.DatabaseContext as DBC+import Crypto.Hash.SHA256 -- | Record a lookup for a specific transaction in the graph. data TransactionIdLookup = TransactionIdLookup TransactionId |@@ -58,7 +62,7 @@ isCommit Commit = True isCommit _ = False -data ROTransactionGraphOperator = ShowGraph+data ROTransactionGraphOperator = ShowGraph | ValidateMerkleHashes deriving Show bootstrapTransactionGraph :: UTCTime -> TransactionId -> DatabaseContext -> TransactionGraph@@ -67,7 +71,8 @@ bootstrapHeads = M.singleton "master" freshTransaction newSchemas = Schemas context M.empty freshTransaction = fresh freshId stamp' newSchemas- bootstrapTransactions = S.singleton freshTransaction+ hashedTransaction = Transaction freshId ((transactionInfo freshTransaction) { merkleHash = calculateMerkleHash freshTransaction emptyTransactionGraph }) newSchemas+ bootstrapTransactions = S.singleton hashedTransaction -- | Create a transaction graph from a context. freshTransactionGraph :: DatabaseContext -> IO (TransactionGraph, TransactionId)@@ -125,10 +130,13 @@ --adds a disconnected transaction to a transaction graph at some head addDisconnectedTransaction :: UTCTime -> TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)-addDisconnectedTransaction stamp' newId headName (DisconnectedTransaction parentId schemas' _) = addTransactionToGraph headName newTrans+addDisconnectedTransaction stamp' newId headName (DisconnectedTransaction parentId schemas' _) graph = addTransactionToGraph headName newTrans' graph where- newTrans = Transaction newId (TI.singleParent parentId stamp') schemas'-+ newTrans = Transaction newId newTInfo schemas'+ newTInfo = TI.singleParent parentId stamp'+ newTrans' = Transaction newId (newTInfo { merkleHash = newHash }) schemas'+ newHash = calculateMerkleHash newTrans graph--lookup parents in graph to calculate+--LOOP addTransactionToGraph :: HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph) addTransactionToGraph headName newTrans graph = do let parentIds' = parentIds newTrans@@ -295,6 +303,7 @@ mkRelationFromList attrs tupleMatrix where attrs = A.attributesFromList [Attribute "id" TextAtomType,+ Attribute "hash" ByteStringAtomType, Attribute "stamp" DateTimeAtomType, Attribute "parents" (RelationAtomType parentAttributes), Attribute "current" BoolAtomType,@@ -304,6 +313,7 @@ tupleGenerator transaction = case transactionParentsRelation transaction graph of Left err -> Left err Right parentTransRel -> Right [TextAtom $ T.pack $ show (transactionId transaction),+ ByteStringAtom $ _unMerkleHash (merkleHash (transactionInfo transaction)), DateTimeAtom (timestamp transaction), RelationAtom parentTransRel, BoolAtom $ parentId == transactionId transaction,@@ -335,10 +345,12 @@ createMergeTransaction stamp' newId (SelectedBranchMergeStrategy selectedBranch) t2@(trans1, trans2) = do graph <- gfGraph selectedTrans <- validateHeadName selectedBranch graph t2- pure $ Transaction newId (TransactionInfo {- parents = NE.fromList [transactionId trans1,- transactionId trans2],- stamp = stamp' }) (schemas selectedTrans)+ pure $ addMerkleHash graph $+ Transaction newId (TransactionInfo {+ parents = NE.fromList [transactionId trans1,+ transactionId trans2],+ stamp = stamp',+ merkleHash = mempty }) (schemas selectedTrans) -- merge functions, relvars, individually createMergeTransaction stamp' newId strat@UnionMergeStrategy t2 =@@ -493,10 +505,12 @@ typeConstructorMapping = types } newSchemas = Schemas newContext (subschemas t1)- pure (Transaction newId (TransactionInfo {- parents = NE.fromList [transactionId t1,- transactionId t2],- stamp = stamp'}) newSchemas)+ pure $ addMerkleHash graph $+ Transaction newId (TransactionInfo {+ parents = NE.fromList [transactionId t1,+ transactionId t2],+ stamp = stamp',+ merkleHash = mempty }) newSchemas lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph@@ -572,3 +586,48 @@ pure (discon''''', graph''''') +addMerkleHash :: TransactionGraph -> Transaction -> Transaction+addMerkleHash graph trans = Transaction (transactionId trans) newInfo (schemas trans)+ where+ newInfo = (transactionInfo trans) { merkleHash = calculateMerkleHash trans graph }+ +-- the new hash includes the parents' ids, the current id, and the hash of the context, and the merkle hashes of the parent transactions+calculateMerkleHash :: Transaction -> TransactionGraph -> MerkleHash+calculateMerkleHash trans graph = MerkleHash $ hashlazy (mconcat [transIds,+ dbcBytes,+ schemasBytes,+ parentMerkleHashes])+ where+ parentMerkleHashes = BL.fromChunks $ map (_unMerkleHash . getMerkleHash) parentTranses+ parentTranses =+ case transactionsForIds (parentIds trans) graph of+ Left RootTransactionTraversalError -> []+ Left e -> error ("failed to find transaction in Merkle hash construction: " ++ show e)+ Right t -> S.toList t+ getMerkleHash t = merkleHash (transactionInfo t)+ transIds = B.encode (transactionId trans : S.toList (parentIds trans))+ dbcBytes = DBC.hashBytes (concreteDatabaseContext trans)+ schemasBytes = B.encode (subschemas trans)++validateMerkleHash :: Transaction -> TransactionGraph -> Either MerkleValidationError ()+validateMerkleHash trans graph = + if expectedHash /= actualHash then+ Left (MerkleValidationError (transactionId trans) expectedHash actualHash)+ else+ pure ()+ where+ expectedHash = merkleHash (transactionInfo trans)+ actualHash = calculateMerkleHash trans graph++data MerkleValidationError = MerkleValidationError TransactionId MerkleHash MerkleHash+ deriving (Show, Eq, Generic)++validateMerkleHashes :: TransactionGraph -> Either [MerkleValidationError] ()+validateMerkleHashes graph =+ if null errs then pure () else Left errs+ where+ errs = S.foldr validateTrans [] (transactionsForGraph graph) + validateTrans trans acc =+ case validateMerkleHash trans graph of+ Left err -> err : acc+ _ -> acc
src/lib/ProjectM36/TransactionInfo.hs view
@@ -1,10 +1,12 @@ module ProjectM36.TransactionInfo where import ProjectM36.Base import Data.Time.Clock-import Data.List.NonEmpty+import qualified Data.List.NonEmpty as NE -- | Create a TransactionInfo with just one parent transaction ID. singleParent :: TransactionId -> UTCTime -> TransactionInfo singleParent tid stamp' = TransactionInfo {- parents = tid :| [],- stamp = stamp' }+ parents = tid NE.:| [],+ stamp = stamp',+ merkleHash = mempty }+
src/lib/ProjectM36/Tupleable.hs view
@@ -6,8 +6,27 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} -module ProjectM36.Tupleable where+module ProjectM36.Tupleable+ ( toInsertExpr+ , toDefineExpr+ , tupleAssocsEqualityPredicate+ , partitionByAttributes+ , toUpdateExpr+ , toDeleteExpr+ , validateAttributes+ , Tupleable(..) + -- * Generics+ , genericToTuple+ , genericFromTuple+ , genericToAttributes+ , TupleableG(..)+ -- ** Options+ , defaultTupleableOptions+ , TupleableOptions()+ , fieldModifier+ ) where+ import Data.Foldable import Data.List (partition) import qualified Data.Map as Map@@ -121,56 +140,109 @@ where nonMatchingAttrs = attributeNamesNotContained actualAttrs expectedAttrs -+-- | Types that can be converted to and from 'RelationTuple'.+--+-- deriving without customization:+--+-- > data Example = Example+-- > { foo :: Integer+-- > , bar :: Text+-- > }+-- > deriving (Generic)+-- >+-- > instance Tupleable Example+--+-- deriving with customization using "ProjectM36.Tupleable.Deriving":+--+-- > data Example = Example+-- > { exampleFoo :: Integer+-- > , exampleBar :: Text+-- > }+-- > deriving stock (Generic)+-- > deriving (Tupleable)+-- > via Codec (Field (DropPrefix "example" >>> CamelCase)) Example class Tupleable a where toTuple :: a -> RelationTuple fromTuple :: RelationTuple -> Either RelationalError a - toAttributes :: proxy a -> Attributes+ toAttributes :: Proxy a -> Attributes default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple- toTuple v = toTupleG (from v)+ toTuple = genericToTuple defaultTupleableOptions default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> Either RelationalError a- fromTuple tup = to <$> fromTupleG tup+ fromTuple = genericFromTuple defaultTupleableOptions - default toAttributes :: (Generic a, TupleableG (Rep a)) => proxy a -> Attributes- toAttributes _ = toAttributesG (from (undefined :: a))+ default toAttributes :: (Generic a, TupleableG (Rep a)) => Proxy a -> Attributes+ toAttributes = genericToAttributes defaultTupleableOptions +-- | Options that influence deriving behavior.+newtype TupleableOptions = TupleableOptions {+ -- | A function that translates record field names into attribute names.+ fieldModifier :: T.Text -> T.Text+ }++-- | The default options for deriving Tupleable instances.+--+-- These options can be customized by using record update syntax. For example,+--+-- > defaultTupleableOptions+-- > { fieldModifier = \fieldName ->+-- > case Data.Text.stripPrefix "example" fieldName of+-- > Nothing -> fieldName+-- > Just attributeName -> attributeName+-- > }+--+-- will result in record field names being translated into attribute names by+-- removing the prefix "example" from the field names.+defaultTupleableOptions :: TupleableOptions+defaultTupleableOptions = TupleableOptions {+ fieldModifier = id+ }++genericToTuple :: (Generic a, TupleableG (Rep a)) => TupleableOptions -> a -> RelationTuple+genericToTuple opts v = toTupleG opts (from v)++genericFromTuple :: (Generic a, TupleableG (Rep a)) => TupleableOptions -> RelationTuple -> Either RelationalError a+genericFromTuple opts tup = to <$> fromTupleG opts tup++genericToAttributes :: forall a. (Generic a, TupleableG (Rep a)) => TupleableOptions -> Proxy a -> Attributes+genericToAttributes opts _ = toAttributesG opts (from (undefined :: a))+ class TupleableG g where- toTupleG :: g a -> RelationTuple- toAttributesG :: g a -> Attributes- fromTupleG :: RelationTuple -> Either RelationalError (g a)+ toTupleG :: TupleableOptions -> g a -> RelationTuple+ toAttributesG :: TupleableOptions -> g a -> Attributes+ fromTupleG :: TupleableOptions -> RelationTuple -> Either RelationalError (g a) isRecordTypeG :: g a -> Bool --data type metadata instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where- toTupleG (M1 v) = toTupleG v- toAttributesG (M1 v) = toAttributesG v- fromTupleG v = M1 <$> fromTupleG v+ toTupleG opts (M1 v) = toTupleG opts v+ toAttributesG opts (M1 v) = toAttributesG opts v+ fromTupleG opts v = M1 <$> fromTupleG opts v isRecordTypeG (M1 v) = isRecordTypeG v --constructor metadata instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) where- toTupleG (M1 v) = RelationTuple attrs atoms+ toTupleG opts (M1 v) = RelationTuple attrs atoms where- attrsToCheck = toAttributesG v+ attrsToCheck = toAttributesG opts v counter = V.generate (V.length attrsToCheck) id attrs = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then Attribute ("attr" <> T.pack (show (num + 1))) typ else attr) counter attrsToCheck atoms = V.fromList (toAtomsG v)- toAttributesG (M1 v) = toAttributesG v- fromTupleG tup = M1 <$> fromTupleG tup+ toAttributesG opts (M1 v) = toAttributesG opts v+ fromTupleG opts tup = M1 <$> fromTupleG opts tup isRecordTypeG (M1 v) = isRecordTypeG v -- product types instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where toTupleG = error "toTupleG"- toAttributesG ~(x :*: y) = toAttributesG x V.++ toAttributesG y --a bit of extra laziness prevents whnf so that we can use toAttributes (undefined :: Test2T Int Int) without throwing an exception- fromTupleG tup = (:*:) <$> fromTupleG tup <*> fromTupleG processedTuple+ toAttributesG opts ~(x :*: y) = toAttributesG opts x V.++ toAttributesG opts y --a bit of extra laziness prevents whnf so that we can use toAttributes (undefined :: Test2T Int Int) without throwing an exception+ fromTupleG opts tup = (:*:) <$> fromTupleG opts tup <*> fromTupleG opts processedTuple where processedTuple = if isRecordTypeG (undefined :: a x) then tup@@ -181,18 +253,22 @@ --selector/record instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where toTupleG = error "toTupleG"- toAttributesG m@(M1 v) = V.singleton (Attribute name aType)+ toAttributesG opts m@(M1 v) = V.singleton (Attribute modifiedName aType) where name = T.pack (selName m)+ modifiedName = if T.null name then+ name+ else+ fieldModifier opts name aType = toAtomTypeG v- fromTupleG tup = if null name then -- non-record type, just pull off the first tuple item+ fromTupleG opts tup = if null name then -- non-record type, just pull off the first tuple item M1 <$> atomv (V.head (tupleAtoms tup)) else do- atom <- atomForAttributeName (T.pack name) tup+ atom <- atomForAttributeName (fieldModifier opts (T.pack name)) tup val <- atomv atom pure (M1 val) where- expectedAtomType = atomType (V.head (toAttributesG (undefined :: M1 S c a x)))+ expectedAtomType = atomType (V.head (toAttributesG opts (undefined :: M1 S c a x))) atomv atom = maybe (Left (AtomTypeMismatchError expectedAtomType (atomTypeForAtom atom)@@ -203,8 +279,8 @@ --constructors with no arguments --basically useless but orthoganal to relationTrue instance TupleableG U1 where- toTupleG _= emptyTuple- toAttributesG _ = emptyAttributes- fromTupleG _ = pure U1+ toTupleG _ _ = emptyTuple+ toAttributesG _ _ = emptyAttributes+ fromTupleG _ _ = pure U1 isRecordTypeG _ = False
+ src/lib/ProjectM36/Tupleable/Deriving.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Newtypes for deriving Tupleable instances with customization using+-- @DerivingVia@.+--+-- Inspired by+-- [Dhall.Deriving](https://hackage.haskell.org/package/dhall-1.33.1/docs/Dhall-Deriving.html)+-- which in turn was inspired by Matt Parson's blog post+-- [Mirror Mirror: Reflection and Encoding Via](https://www.parsonsmatt.org/2020/02/04/mirror_mirror.html).+--+-- required extensions:+--+-- * DerivingVia+-- * DeriveGenerics+-- * TypeOperators (for @('<<<')@ and @('>>>')@)+-- * DataKinds (for types that take a string argument)++module ProjectM36.Tupleable.Deriving+ ( -- * DerivingVia Newtype+ Codec(..)++ -- * Type-level Options+ , ModifyOptions(..)+ , Field++ -- * Type-level 'T.Text' -> 'T.Text' Functions+ , ModifyText(..)+ , AddPrefix+ , DropPrefix+ , AddSuffix+ , DropSuffix+ , UpperCase+ , LowerCase+ , TitleCase+ , CamelCase+ , PascalCase+ , SnakeCase+ , SpinalCase+ , TrainCase++ -- * Composition+ , AsIs+ , type (<<<)+ , type (>>>)++ -- * Re-Exports+ , Generic+ , module ProjectM36.Tupleable+ ) where+import Data.Maybe (fromMaybe)+import Data.Proxy+import qualified Data.Text as T+import Data.Text.Manipulate+import GHC.TypeLits+import GHC.Generics (Generic, Rep)+import ProjectM36.Tupleable+++-- | A newtype wrapper to allow for easier deriving of 'Tupleable' instances+-- with customization.+--+-- The @tag@ type variable can be used to specify options for converting the+-- datatype to and from a 'RelationTuple'. For example,+--+-- > data Example = Example+-- > { exampleFoo :: Int+-- > , exampleBar :: Int+-- > }+-- > deriving stock (Generic)+-- > deriving (Tupleable)+-- > via Codec (Field (DropPrefix "example" >>> CamelCase)) Example+--+-- will derive an instance of 'Tupleable' where field names are translated into+-- attribute names by dropping the prefix @"example"@ and then converting the+-- result to camelCase. So @"exampleFoo"@ becomes @"foo"@ and @"exampleBar"@+-- becomes @"bar"@.+--+-- Requires the @DerivingGeneric@ and @DerivingVia@ extensions to be enabled.+newtype Codec tag a = Codec { unCodec :: a }++instance (ModifyOptions tag, Generic a, TupleableG (Rep a)) => Tupleable (Codec tag a) where+ toTuple v = genericToTuple opts (unCodec v)+ where+ opts = modifyOptions (Proxy :: Proxy tag) defaultTupleableOptions++ fromTuple tup = Codec <$> genericFromTuple opts tup+ where+ opts = modifyOptions (Proxy :: Proxy tag) defaultTupleableOptions++ toAttributes _ = genericToAttributes opts (Proxy :: Proxy a)+ where+ opts = modifyOptions (Proxy :: Proxy tag) defaultTupleableOptions++-- | Types that can be used as tags for 'Codec'.+class ModifyOptions a where+ modifyOptions :: proxy a -> TupleableOptions -> TupleableOptions++-- | Change how record field names are translated into attribute names. For+-- example,+--+-- > Field SnakeCase+--+-- will translate the field name @fooBar@ into the attribute name @foo_bar@.+data Field a++instance ModifyText a => ModifyOptions (Field a) where+ modifyOptions _ opts = opts { fieldModifier = newFieldModifier }+ where+ newFieldModifier = modifyText (Proxy :: Proxy a) . fieldModifier opts++-- | Types that can be used in options that modify 'T.Text' such as in 'Field'.+class ModifyText a where+ modifyText :: proxy a -> T.Text -> T.Text++-- | Add a prefix. @AddPrefix "foo"@ will transform @"bar"@ into @"foobar"@.+data AddPrefix (prefix :: Symbol)++instance KnownSymbol prefix => ModifyText (AddPrefix prefix) where+ modifyText _ oldText = prefixText <> oldText+ where+ prefixText = T.pack (symbolVal (Proxy :: Proxy prefix))++-- | Drop a prefix. @DropPrefix "bar"@ will transform @"foobar"@ into @"foo"@.+data DropPrefix (prefix :: Symbol)++instance KnownSymbol prefix => ModifyText (DropPrefix prefix) where+ modifyText _ oldText = fromMaybe oldText (T.stripPrefix prefixText oldText)+ where+ prefixText = T.pack (symbolVal (Proxy :: Proxy prefix))++-- | Add a suffix. @AddSuffix "bar"@ will transform @"foo"@ into @"foobar"@.+data AddSuffix (suffix :: Symbol)++instance KnownSymbol suffix => ModifyText (AddSuffix suffix) where+ modifyText _ oldText = oldText <> suffixText+ where+ suffixText = T.pack (symbolVal (Proxy :: Proxy suffix))++-- | Drop a suffix. @DropSuffix "bar"@ will transform @"foobar"@ into @"foo"@.+data DropSuffix (suffix :: Symbol)++instance KnownSymbol suffix => ModifyText (DropSuffix suffix) where+ modifyText _ oldText = fromMaybe oldText (T.stripSuffix suffixText oldText)+ where+ suffixText = T.pack (symbolVal (Proxy :: Proxy suffix))++-- | Convert to UPPERCASE. Will transform @"foobar"@ into @\"FOOBAR\"@.+data UpperCase++instance ModifyText UpperCase where+ modifyText _ = T.toUpper++-- | Convert to lowercase. Will transform @\"FOOBAR\"@ into @"foobar"@.+data LowerCase++instance ModifyText LowerCase where+ modifyText _ = T.toLower++-- | Convert to Title Case. Will transform @"fooBar"@ into @\"Foo Bar\"@.+data TitleCase++instance ModifyText TitleCase where+ modifyText _ = toTitle++-- | Convert to camelCase. Will transform @"foo_bar"@ into @"fooBar"@.+data CamelCase++instance ModifyText CamelCase where+ modifyText _ = toCamel++-- | Convert to PascalCase. Will transform @"foo_bar"@ into @\"FooBar\"@.+data PascalCase++instance ModifyText PascalCase where+ modifyText _ = toPascal++-- | Convert to snake_case. Will transform @"fooBar"@ into @"foo_bar"@.+data SnakeCase++instance ModifyText SnakeCase where+ modifyText _ = toSnake++-- | Convert to spinal-case. will transform @"fooBar"@ into @"foo-bar"@.+data SpinalCase++instance ModifyText SpinalCase where+ modifyText _ = toSpinal++-- | Convert to Train-Case. Will transform @"fooBar"@ into @\"Foo-Bar\"@.+data TrainCase++instance ModifyText TrainCase where+ modifyText _ = toTrain++-- | Identity option.+type AsIs = ()++instance ModifyOptions () where+ modifyOptions _ = id++instance ModifyText () where+ modifyText _ = id++-- | Right to left composition.+--+-- Requires the @TypeOperators@ extension to be enabled.+data a <<< b++instance (ModifyOptions a, ModifyOptions b) => ModifyOptions (a <<< b) where+ modifyOptions _ = modifyOptions (Proxy :: Proxy a) . modifyOptions (Proxy :: Proxy b)++instance (ModifyText a, ModifyText b) => ModifyText (a <<< b) where+ modifyText _ = modifyText (Proxy :: Proxy a) . modifyText (Proxy :: Proxy b)++-- | Left to right composition.+--+-- Requires the @TypeOperators@ extension to be enabled.+data a >>> b++instance (ModifyOptions a, ModifyOptions b) => ModifyOptions (a >>> b) where+ modifyOptions _ = modifyOptions (Proxy :: Proxy b) . modifyOptions (Proxy :: Proxy a)++instance (ModifyText a, ModifyText b) => ModifyText (a >>> b) where+ modifyText _ = modifyText (Proxy :: Proxy b) . modifyText (Proxy :: Proxy a)
test/Relation/Tupleable.hs view
@@ -1,13 +1,22 @@-{-# LANGUAGE DeriveGeneric, FlexibleInstances, FlexibleContexts, DeriveAnyClass #-}+{-# LANGUAGE+ DeriveGeneric+ , FlexibleInstances+ , FlexibleContexts+ , DeriveAnyClass+ , ScopedTypeVariables+ , TypeApplications+ , DataKinds+ , TypeOperators+ , AllowAmbiguousTypes+ #-} import Test.HUnit-import ProjectM36.Tupleable+import ProjectM36.Tupleable.Deriving import ProjectM36.Atomable import ProjectM36.Attribute import ProjectM36.Error import Data.Binary import ProjectM36.Base import Control.DeepSeq (NFData)-import GHC.Generics import qualified Data.Vector as V import qualified Data.Map as M import qualified Data.Text as T@@ -58,6 +67,13 @@ attr9C :: Double } deriving (Generic, Show, Eq)++data Test10T = Test10C {+ longAttrNameA10 :: Integer,+ long_attr_name_b10 :: Integer,+ longMixed_attr_NameC10 :: Integer+ }+ deriving (Generic, Show, Eq) instance Tupleable Test1T @@ -83,7 +99,7 @@ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess testList :: Test-testList = TestList [testADT1, testADT2, testADT3, testADT4, testADT6, testADT7, testADT8, testInsertExpr, testDefineExpr, testUpdateExpr, testUpdateExprEmptyAttrs, testDeleteExpr, testUpdateExprWrongAttr, testReorderedTuple]+testList = TestList [testADT1, testADT2, testADT3, testADT4, testADT6, testADT7, testADT8, testInsertExpr, testDefineExpr, testUpdateExpr, testUpdateExprEmptyAttrs, testDeleteExpr, testUpdateExprWrongAttr, testReorderedTuple, testAddPrefixField, testDropPrefixField, testAddSuffixField, testDropSuffixField, testUpperCaseField, testLowerCaseField, testTitleCaseField, testCamelCaseField, testPascalCaseField, testSnakeCaseField, testSpinalCaseField, testTrainCaseField, testAsIsCodec, testAsIsField, testComposeRLCodec, testComposeRLField, testComposeLRCodec, testComposeLRField] testADT1 :: Test testADT1 = TestCase $ assertEqual "one record constructor" (Right example) (fromTuple (toTuple example))@@ -200,3 +216,153 @@ attrC = 4} actual = fromTuple . tupleRev . toTuple $ expected assertEqual "reordered tuple" (Right expected) actual++testCodec :: forall tag. ModifyOptions tag => String -> [AttributeName] -> Test+testCodec msg expected = TestCase $+ assertEqual msg (S.fromList expected) actual+ where+ actual = attributeNameSet $ toAttributes (Proxy :: Proxy (Codec tag Test10T))++testAddPrefixField :: Test+testAddPrefixField = testCodec+ @(Field (AddPrefix "prefix_"))+ "codec field add prefix attributes"+ ["prefix_longAttrNameA10",+ "prefix_long_attr_name_b10",+ "prefix_longMixed_attr_NameC10"]++testDropPrefixField :: Test+testDropPrefixField = testCodec+ @(Field (DropPrefix "long"))+ "codec field drop prefix"+ ["AttrNameA10",+ "_attr_name_b10",+ "Mixed_attr_NameC10"]++testAddSuffixField :: Test+testAddSuffixField = testCodec+ @(Field (AddSuffix "_suffix"))+ "codec field add suffix"+ ["longAttrNameA10_suffix",+ "long_attr_name_b10_suffix",+ "longMixed_attr_NameC10_suffix"]++testDropSuffixField :: Test+testDropSuffixField = testCodec+ @(Field (DropSuffix "10"))+ "codec field drop suffix"+ ["longAttrNameA",+ "long_attr_name_b",+ "longMixed_attr_NameC"]++testUpperCaseField :: Test+testUpperCaseField = testCodec+ @(Field UpperCase)+ "codec field uppercase"+ ["LONGATTRNAMEA10",+ "LONG_ATTR_NAME_B10",+ "LONGMIXED_ATTR_NAMEC10"]++testLowerCaseField :: Test+testLowerCaseField = testCodec+ @(Field LowerCase)+ "codec field lowercase"+ ["longattrnamea10",+ "long_attr_name_b10",+ "longmixed_attr_namec10"]++testTitleCaseField :: Test+testTitleCaseField = testCodec+ @(Field TitleCase)+ "codec field title case"+ ["Long Attr Name A10",+ "Long Attr Name B10",+ "Long Mixed Attr Name C10"]++testCamelCaseField :: Test+testCamelCaseField = testCodec+ @(Field CamelCase)+ "codec field camel case"+ ["longAttrNameA10",+ "longAttrNameB10",+ "longMixedAttrNameC10"]++testPascalCaseField :: Test+testPascalCaseField = testCodec+ @(Field PascalCase)+ "codec field pascal case"+ ["LongAttrNameA10",+ "LongAttrNameB10",+ "LongMixedAttrNameC10"]++testSnakeCaseField :: Test+testSnakeCaseField = testCodec+ @(Field SnakeCase)+ "codec field snake case"+ ["long_attr_name_a10",+ "long_attr_name_b10",+ "long_mixed_attr_name_c10"]++testSpinalCaseField :: Test+testSpinalCaseField = testCodec+ @(Field SpinalCase)+ "codec field spinal case"+ ["long-attr-name-a10",+ "long-attr-name-b10",+ "long-mixed-attr-name-c10"]++testTrainCaseField :: Test+testTrainCaseField = testCodec+ @(Field TrainCase)+ "codec field train case"+ ["Long-Attr-Name-A10",+ "Long-Attr-Name-B10",+ "Long-Mixed-Attr-Name-C10"]++testAsIsCodec :: Test+testAsIsCodec = testCodec+ @AsIs+ "codec as is"+ ["longAttrNameA10",+ "long_attr_name_b10",+ "longMixed_attr_NameC10"]++testAsIsField :: Test+testAsIsField = testCodec+ @(Field AsIs)+ "codec field as is"+ ["longAttrNameA10",+ "long_attr_name_b10",+ "longMixed_attr_NameC10"]++testComposeRLCodec :: Test+testComposeRLCodec = testCodec+ @(Field UpperCase <<< Field (DropPrefix "long"))+ "codec (<<<)"+ ["ATTRNAMEA10",+ "_ATTR_NAME_B10",+ "MIXED_ATTR_NAMEC10"]++testComposeRLField :: Test+testComposeRLField = testCodec+ @(Field (UpperCase <<< DropPrefix "long"))+ "codec field (<<<)"+ ["ATTRNAMEA10",+ "_ATTR_NAME_B10",+ "MIXED_ATTR_NAMEC10"]++testComposeLRCodec :: Test+testComposeLRCodec = testCodec+ @(Field (DropPrefix "long") >>> Field UpperCase)+ "codec (>>>)"+ ["ATTRNAMEA10",+ "_ATTR_NAME_B10",+ "MIXED_ATTR_NAMEC10"]++testComposeLRField :: Test+testComposeLRField = testCodec+ @(Field (DropPrefix "long" >>> UpperCase))+ "codec field (>>>)"+ ["ATTRNAMEA10",+ "_ATTR_NAME_B10",+ "MIXED_ATTR_NAMEC10"]
test/TransactionGraph/Merge.hs view
@@ -4,6 +4,7 @@ import ProjectM36.Attribute import ProjectM36.Relation import ProjectM36.Transaction+import ProjectM36.TransactionInfo as TI import ProjectM36.TransactionGraph import ProjectM36.Error import ProjectM36.Key@@ -14,6 +15,17 @@ import qualified Data.ByteString.Lazy as BS import System.Exit+++++++++++ import Data.Word import qualified Data.UUID as U import qualified Data.Set as S@@ -21,7 +33,6 @@ import Data.Maybe import Data.Time.Clock import Data.Time.Calendar-import qualified Data.List.NonEmpty as NE {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} @@ -61,10 +72,9 @@ uuidA = fakeUUID 10 uuidB = fakeUUID 11 uuidRoot = fakeUUID 1- parents' = uuidRoot NE.:| [] rootContext = concreteDatabaseContext rootTrans- (_, bsGraph') <- addTransaction "branchA" (createTrans uuidA (TransactionInfo parents' testTime) rootContext) bsGraph- (_, bsGraph'') <- addTransaction "branchB" (createTrans uuidB (TransactionInfo parents' testTime) rootContext) bsGraph'+ (_, bsGraph') <- addTransaction "branchA" (createTrans uuidA (TI.singleParent uuidRoot testTime) rootContext) bsGraph+ (_, bsGraph'') <- addTransaction "branchB" (createTrans uuidB (TI.singleParent uuidRoot testTime) rootContext) bsGraph' pure bsGraph'' addTransaction :: HeadName -> Transaction -> TransactionGraph -> IO (Transaction, TransactionGraph)@@ -108,7 +118,7 @@ baseGraph <- basicTransactionGraph transA <- assertMaybe (transactionForHead "branchA" baseGraph) "failed to get branchA" transB <- assertMaybe (transactionForHead "branchB" baseGraph) "failed to get branchB"- (_, graph) <- addTransaction "branchC" (createTrans (fakeUUID 12) (TransactionInfo (fakeUUID 1 NE.:| []) testTime) (concreteDatabaseContext transA)) baseGraph+ (_, graph) <- addTransaction "branchC" (createTrans (fakeUUID 12) (TI.singleParent (fakeUUID 1) testTime) (concreteDatabaseContext transA)) baseGraph subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph (transactionHeadsForGraph baseGraph) transA transB S.empty assertGraph subgraph let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg) @@ -127,13 +137,13 @@ updatedBranchBContext <- case runDatabaseContextEvalMonad branchBContext env (optimizeAndEvalDatabaseContextExpr True (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) of Left err -> assertFailure (show err) >> undefined Right st -> pure $ dbc_context st- (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans NE.:| []) testTime) updatedBranchBContext) graph+ (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TI.singleParent (transactionId branchBTrans) testTime) updatedBranchBContext) graph branchBTrans' <- assertMaybe (transactionForHead "branchB" graph') "failed to get branchB head" assertEqual "branchB id 3" (fakeUUID 3) (transactionId branchBTrans') -- add another transaction to branchA branchATrans <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA head" - (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans NE.:| []) testTime) (concreteDatabaseContext branchATrans)) graph'+ (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TI.singleParent (transactionId branchATrans) testTime) (concreteDatabaseContext branchATrans)) graph' branchATrans' <- assertMaybe (transactionForHead "branchA" graph'') "failed to get branchA head" assertEqual "branchA id 4" (fakeUUID 4) (transactionId branchATrans') @@ -156,7 +166,7 @@ updatedBranchBContext <- case runDatabaseContextEvalMonad branchBContext env (optimizeAndEvalDatabaseContextExpr True (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) of Left err -> assertFailure (show err) >> undefined Right st -> pure (dbc_context st)- (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans NE.:| []) testTime) updatedBranchBContext) graph+ (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TI.singleParent (transactionId branchBTrans) testTime) updatedBranchBContext) graph --create the merge transaction in the graph let eGraph' = runGraphRefRelationalExprM gfEnv $ mergeTransactions testTime (fakeUUID 4) (fakeUUID 10) (SelectedBranchMergeStrategy "branchA") ("branchA", "branchB") gfEnv = freshGraphRefRelationalExprEnv Nothing graph'@@ -185,8 +195,8 @@ branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert conflictRelVarName (ExistingRelation branchBRelVar) (relationVariables (concreteDatabaseContext branchBTrans))} conflictRelVarName = "conflictRelVar" - (_, graph') <- addTransaction "branchA" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchATrans NE.:| []) testTime) branchAContext) graph- (_, graph'') <- addTransaction "branchB" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchBTrans NE.:| []) testTime) branchBContext) graph'+ (_, graph') <- addTransaction "branchA" (createTrans (fakeUUID 3) (TI.singleParent (transactionId branchATrans) testTime) branchAContext) graph+ (_, graph'') <- addTransaction "branchB" (createTrans (fakeUUID 4) (TI.singleParent (transactionId branchBTrans) testTime) branchBContext) graph' -- validate that the conflict is hidden because we preferred a branch let merged = runGraphRefRelationalExprM env $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) (UnionPreferMergeStrategy "branchB") ("branchA", "branchB") env = freshGraphRefRelationalExprEnv Nothing graph''@@ -215,7 +225,7 @@ branchAOnlyIncDepName = "branchAOnlyIncDep" branchBOnlyRelVarName = "branchBOnlyRelVar" branchAOnlyIncDep = InclusionDependency (ExistingRelation relationTrue) (ExistingRelation relationTrue)- (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans NE.:| []) testTime) updatedBranchBContext) graph+ (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TI.singleParent (transactionId branchBTrans) testTime) updatedBranchBContext) graph let env = freshGraphRefRelationalExprEnv Nothing graph' (discon, _) <- assertEither $ runGraphRefRelationalExprM env $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 10) UnionMergeStrategy ("branchA", "branchB") let Just rvExpr = M.lookup branchBOnlyRelVarName (relationVariables (Discon.concreteDatabaseContext discon))@@ -223,7 +233,7 @@ reEnv = freshGraphRefRelationalExprEnv (Just (Discon.concreteDatabaseContext discon)) graph assertEqual "branchBOnlyRelVar should appear in the merge" relationTrue rvRel- (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans NE.:| []) testTime) updatedBranchAContext) graph'+ (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TI.singleParent (transactionId branchATrans) testTime) updatedBranchAContext) graph' let eMergeGraph = runGraphRefRelationalExprM gfEnv $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") gfEnv = freshGraphRefRelationalExprEnv Nothing graph'' case eMergeGraph of@@ -243,7 +253,7 @@ conflictRelVar <- assertEither $ mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) [] let conflictContextA = updatedBranchAContext {relationVariables = M.insert branchBOnlyRelVarName (ExistingRelation conflictRelVar) (relationVariables updatedBranchAContext) } conflictBranchATrans <- assertMaybe (transactionForHead "branchA" graph'') "retrieving head transaction for expected conflict"- (_, graph''') <- addTransaction "branchA" (createTrans (fakeUUID 6) (TransactionInfo (transactionId conflictBranchATrans NE.:| []) testTime) conflictContextA) graph''+ (_, graph''') <- addTransaction "branchA" (createTrans (fakeUUID 6) (TI.singleParent (transactionId conflictBranchATrans) testTime) conflictContextA) graph'' let failingMerge = runGraphRefRelationalExprM gfEnv' $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") gfEnv' = freshGraphRefRelationalExprEnv Nothing graph''' case failingMerge of@@ -272,9 +282,9 @@ --add the rv in new commits to both branches- (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans NE.:| []) testTime) branchBContext) graph+ (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TI.singleParent (transactionId branchBTrans) testTime) branchBContext) graph - (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans NE.:| []) testTime) branchAContext) graph'+ (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TI.singleParent (transactionId branchATrans) testTime) branchAContext) graph' --check that the union merge fails due to a violated constraint let eMerge = runGraphRefRelationalExprM env $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB")
test/TransactionGraph/Persist.hs view
@@ -3,11 +3,12 @@ import ProjectM36.Base import ProjectM36.Persist (DiskSync(NoDiskSync)) import ProjectM36.TransactionGraph.Persist-import ProjectM36.TransactionGraph+import ProjectM36.TransactionGraph as TG import ProjectM36.Transaction import ProjectM36.DateExamples import System.IO.Temp import System.Exit+import System.Directory import Data.Either import Data.UUID.V4 (nextRandom) import System.FilePath@@ -16,10 +17,9 @@ import qualified Data.Set as S import Data.Time.Clock import Data.Time.Calendar-#ifdef PM36_HASKELL_SCRIPTING-import ProjectM36.Client+import ProjectM36.Client as C import ProjectM36.Relation-#endif+import ProjectM36.Transaction.Persist main :: IO () main = do @@ -29,7 +29,8 @@ testList :: Test testList = TestList [testBootstrapDB, testDBSimplePersistence,- testFunctionPersistence]+ testFunctionPersistence,+ testMerkleHashValidation] stamp' :: UTCTime@@ -74,8 +75,63 @@ case graphErr of Left err -> assertFailure (show err) Right graph'' -> assertBool "graph equality" (mapEq graph'' == mapEq graph')- +testMerkleHashValidation :: Test+testMerkleHashValidation = TestCase $+ -- add a commit and validate the hashes successfully+ withSystemTempDirectory "m36testdb" $ \tempdir -> do+ let dbdir = tempdir </> "dbdir"+ connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback []+ conn <- assertIOEither $ connectProjectM36 connInfo+ sess <- assertIOEither $ createSessionAtHead conn "master"+ Right _ <- executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue))+ Right _ <- commit sess conn+ val <- C.validateMerkleHashes sess conn+ assertEqual "merkle success" (Right ()) val++ --read graph from disk+ conn' <- assertIOEither $ connectProjectM36 connInfo+ sess' <- assertIOEither $ createSessionAtHead conn' "master"++ val' <- C.validateMerkleHashes sess' conn'+ assertEqual "merkle read again success" (Right ()) val'++ --alter the on-disk representation and check that the hash validation fails+ eGraph <- transactionGraphLoad dbdir emptyTransactionGraph Nothing+ case eGraph of+ Left err -> assertFailure $ "failed to load graph" ++ show err+ Right graph -> do+ let trans = transactionHeadsForGraph graph M.! "master"+ updatedTrans = Transaction (transactionId trans) (transactionInfo trans) updatedSchemas+ transactionDir' = dbdir </> show (transactionId trans)+ updatedSchemas =+ case schemas trans of+ Schemas ctx sschemas ->+ let updatedContext = ctx {+ relationVariables = M.insert "malicious" (ExistingRelation relationFalse) (relationVariables ctx)+ } in+ Schemas updatedContext sschemas+ maliciousGraph = TransactionGraph malHeads malTransSet+ malHeads = M.insert "master" updatedTrans (transactionHeadsForGraph graph)+ malTransSet = S.insert updatedTrans (transactionsForGraph graph)+ malMerkleHash = calculateMerkleHash updatedTrans maliciousGraph+ regMerkleHash = merkleHash (transactionInfo trans)+ --validate and fail+ let val'' = TG.validateMerkleHashes maliciousGraph+ assertEqual "loaded graph merkle hashes" (Left [MerkleValidationError (transactionId trans) regMerkleHash malMerkleHash]) val''+ --delete existing transaction directory+ removeDirectoryRecursive transactionDir'+ writeTransaction NoDiskSync dbdir updatedTrans++ --read graph from disk+ eConnFail <- connectProjectM36 connInfo+ case eConnFail of+ Left err -> + assertEqual "open connection merkle validation" (DatabaseValidationError [MerkleValidationError (transactionId trans) regMerkleHash malMerkleHash]) err+ Right _ -> assertFailure "open connection validation" +++ --only Haskell-scripted dbc and atom functions can be serialized testFunctionPersistence :: Test #if !defined(PM36_HASKELL_SCRIPTING)@@ -103,10 +159,11 @@ let expectedRel = mkRelationFromList (attributesFromList [Attribute "a" IntAtomType]) [[IntAtom 3]] assertEqual "testdisk dbc function run" expectedRel res +#endif + assertIOEither :: (Show a) => IO (Either a b) -> IO b assertIOEither x = do ret <- x case ret of Left err -> assertFailure (show err) >> undefined Right val -> pure val-#endif
test/TutorialD/Interpreter.hs view
@@ -78,7 +78,8 @@ testAtomFunctionArgumentMismatch, testInvalidDataConstructor, testBasicList,- testRelationDeclarationMismatch+ testRelationDeclarationMismatch,+ testInvalidTuples ] simpleRelTests :: Test@@ -691,3 +692,11 @@ testRelationDeclarationMismatch = TestCase $ do (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback expectTutorialDErr sessionId dbconn (T.isPrefixOf "AtomTypeMismatchError") "data A a = A a | B | C; a := relation{a A Integer}{tuple{a A \"1\"}}"++--generate errors when the tuples in a new relation don't match+testInvalidTuples :: Test+testInvalidTuples = TestCase $ do+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+ expectTutorialDErr sessionId dbconn (T.isPrefixOf "AttributeNamesMismatchError") ":showexpr relation{tuple{a 1},tuple{b 2}}"+ expectTutorialDErr sessionId dbconn (T.isPrefixOf "AttributeNamesMismatchError") ":showexpr relation{tuple{a 1},tuple{a 2, b 3}}"+-- expectTutorialDErr sessionId dbconn (T.isPrefixOf "ParseErrorBundle") ":showexpr relation{tuple{a 2, a 3}}" --parse failure can't be validated with this function