diff --git a/Changelog.markdown b/Changelog.markdown --- a/Changelog.markdown +++ b/Changelog.markdown @@ -1,3 +1,13 @@ +# 2017-08-01 + +## autoMergeToHead + +In preparation for the simpler monad client API, ProjectM36.Client now includes a server-side merge for new transactions called "[automerge](https://github.com/agentm/project-m36/issues/33)". This feature should reduce head contention in cases where new transactions can be simply merged to the head without additional processing. The trade-off is reduced ```TransactionIsNotAHeadError```s but an increased chance of merge errors. The feature operates similarly to a server-side git rebase. + +## critical bug in merging + +Successfully merged transactions did not have their constraints validated. Fixed. + # 2017-06-12 ## add file locking diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,5 +1,11 @@ # Ξ Project:M36 Relational Algebra Engine +[![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)](https://www.haskell.org) +[![Public Domain](https://img.shields.io/badge/license-Public%20Domain-brightgreen.svg)](http://unlicense.org) +[![Hackage](https://img.shields.io/hackage/v/project-m36.svg)](http://hackage.haskell.org/package/project-m36) +[![Hackage dependency status](https://img.shields.io/hackage-deps/v/project-m36.svg)](http://packdeps.haskellers.com/feed?needle=project-m36) +[![Build status](https://travis-ci.org/agentm/project-m36.svg?branch=master)](https://travis-ci.org/agentm/project-m36) + *Software can always be made faster, but rarely can it be made more correct.* ## Introduction @@ -35,6 +41,7 @@ * [Developer's Blog](https://agentm.github.io/project-m36/) * [Mailing List/Discussion Group](https://groups.google.com/d/forum/project-m36) * IRC Channel: chat.freenode.net #project-m36 +* [Hackage](https://hackage.haskell.org/package/project-m36) ## Documentation diff --git a/examples/SimpleClient.hs b/examples/SimpleClient.hs --- a/examples/SimpleClient.hs +++ b/examples/SimpleClient.hs @@ -9,30 +9,30 @@ -- 2. conncted to the remote database eConn <- connectProjectM36 connInfo case eConn of - Left err -> putStrLn (show err) + Left err -> print err Right conn -> do --3. create a session on the "master" branch - eSessionId <- createSessionAtHead "master" conn + eSessionId <- createSessionAtHead conn "master" case eSessionId of - Left err -> putStrLn (show err) + Left err -> print err Right sessionId -> do --4. define a new relation variable with a DatabaseContext expression let attrList = [Attribute "name" TextAtomType, Attribute "age" IntAtomType] attrs = attributesFromList attrList mErr1 <- executeDatabaseContextExpr sessionId conn (Define "person" (map NakedAttributeExpr attrList)) - putStrLn (show mErr1) + print mErr1 --5. add a tuple to the relation referenced by the relation variable let (Right tupSet) = mkTupleSetFromList attrs [[TextAtom "Bob", IntAtom 45]] mErr2 <- executeDatabaseContextExpr sessionId conn (Insert "person" (MakeStaticRelation attrs tupSet)) - putStrLn (show mErr2) + print mErr2 --6. execute a relational algebra query let restrictionPredicate = AttributeEqualityPredicate "name" (NakedAtomExpr (TextAtom "Steve")) eRel <- executeRelationalExpr sessionId conn (Restrict restrictionPredicate (RelationVariable "person" ())) case eRel of - Left err -> putStrLn (show err) - Right rel -> putStrLn (show $ showRelation rel) + Left err -> print err + Right rel -> print (showRelation rel) --7. close the connection close conn diff --git a/examples/blog.hs b/examples/blog.hs new file mode 100644 --- /dev/null +++ b/examples/blog.hs @@ -0,0 +1,103 @@ +-- a simple example of a blog schema +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-} + +import ProjectM36.Client +import ProjectM36.Relation +import ProjectM36.Tupleable + +import Data.Either +import GHC.Generics +import Data.Binary +import qualified Data.Text as T +import Data.Time.Clock +import Data.Time.Calendar +import Control.DeepSeq + +--define your data types +data Blog = Blog { + title :: T.Text, + stamp :: UTCTime, + category :: Category --note that this type is an algebraic data type + } + deriving (Generic, Show) --derive Generic so that Tupleable can use default instances + +--instantiate default Tupleable instances +instance Tupleable Blog + +data Comment = Comment { + blogTitle :: T.Text, + commentTime :: UTCTime, + contents :: T.Text + } deriving (Generic, Show) + +instance Tupleable Comment + +data Category = Food | Cats | Photos | Other T.Text -- note that this data type could not be represented by an "enumeration" as found in SQL databases + deriving (Atomable, Eq, Show, NFData, Binary, Generic) -- derive Atomable so that values of this type can be stored as a database value + +-- add some short-hand error handling- your application should have proper handling +handleIOError :: Show e => IO (Either e a) -> IO a +handleIOError m = do + v <- m + handleError v + +handleError :: Show e => Either e a -> IO a +handleError eErr = case eErr of + Left err -> print err >> error "Died due to errors." + Right v -> pure v + +handleIOErrors :: Show e => IO [Either e a] -> IO [a] +handleIOErrors m = do + eErrs <- m + case lefts eErrs of + [] -> pure (rights eErrs) + err:_ -> handleError (Left err) + +main :: IO () +main = do + --connect to the database + let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] + conn <- handleIOError $ connectProjectM36 connInfo + + sessionId <- handleIOError $ createSessionAtHead conn "master" + + createSchema sessionId conn + insertSampleData sessionId conn + executeSampleQueries sessionId conn + +--define the schema with the new Category atom (data) type, blog relvar, a comment relvar, and a foreign key relationship between them +createSchema :: SessionId -> Connection -> IO () +createSchema sessionId conn = do + _ <- handleIOErrors $ mapM (executeDatabaseContextExpr sessionId conn) [ + toAddTypeExpr (undefined :: Category), + toDefineExpr (undefined :: Blog) "blog", + toDefineExpr (undefined :: Comment) "comment", + databaseContextExprForForeignKey "blog_comment" ("comment", ["blogTitle"]) ("blog", ["title"]) ] + pure () + +--create some sample values and insert them into the database's relation variables +insertSampleData :: SessionId -> Connection -> IO () +insertSampleData sessionId conn = do + let blogs = [Blog { title = "Eat More Tofu", + stamp = UTCTime (fromGregorian 2017 5 8) (secondsToDiffTime 1000), + category = Food }, + Blog { title = "Cat Falls Off Table", + stamp = UTCTime (fromGregorian 2017 6 10) (secondsToDiffTime 2000), + category = Cats } + ] + comments = [Comment { blogTitle = "Cat Falls Off Table", + commentTime = UTCTime (fromGregorian 2017 7 8) (secondsToDiffTime 3000), + contents = "more cats please" }] + insertBlogsExpr <- handleError $ toInsertExpr blogs "blog" + handleIOError $ executeDatabaseContextExpr sessionId conn insertBlogsExpr + + insertCommentsExpr <- handleError $ toInsertExpr comments "comment" + handleIOError $ executeDatabaseContextExpr sessionId conn insertCommentsExpr + +--issue a query and marshal the data back to the original data value +executeSampleQueries :: SessionId -> Connection -> IO () +executeSampleQueries sessionId conn = do + commentsRelation <- handleIOError $ executeRelationalExpr sessionId conn (RelationVariable "comment" ()) + + comments <- toList commentsRelation >>= mapM (handleError . fromTuple) :: IO [Comment] + print comments diff --git a/examples/hair.hs b/examples/hair.hs --- a/examples/hair.hs +++ b/examples/hair.hs @@ -23,17 +23,14 @@ conn <- eCheck $ connectProjectM36 connInfo --create a database session at the default branch of the fresh database - sessionId <- eCheck $ createSessionAtHead "master" conn + sessionId <- eCheck $ createSessionAtHead conn "master" - let mCheck v = v >>= \x -> case x of - Just err -> error (show err) - Nothing -> pure () --create the data type in the database context - mCheck $ executeDatabaseContextExpr sessionId conn (toDatabaseContextExpr (undefined :: Hair)) + eCheck $ executeDatabaseContextExpr sessionId conn (toAddTypeExpr (undefined :: Hair)) --create a relation with the new Hair AtomType let blond = NakedAtomExpr (toAtom Blond) - mCheck $ executeDatabaseContextExpr sessionId conn (Assign "people" (MakeRelationFromExprs Nothing [ + eCheck $ executeDatabaseContextExpr sessionId conn (Assign "people" (MakeRelationFromExprs Nothing [ TupleExpr (M.fromList [("hair", blond), ("name", NakedAtomExpr (TextAtom "Colin"))])])) let restrictionPredicate = AttributeEqualityPredicate "hair" blond diff --git a/examples/out_of_the_tarpit.hs b/examples/out_of_the_tarpit.hs --- a/examples/out_of_the_tarpit.hs +++ b/examples/out_of_the_tarpit.hs @@ -2,50 +2,35 @@ {-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-} import ProjectM36.Client import ProjectM36.DataTypes.Primitive -import qualified Data.Map as M -import Data.Maybe -import Control.Monad +import ProjectM36.Tupleable +import ProjectM36.Relation +import ProjectM36.Error +import Data.Either import GHC.Generics import Data.Binary import Control.DeepSeq +import qualified Data.Text as T +import Data.Time.Calendar --create various database value (atom) types -addressAtomType :: AtomType -addressAtomType = TextAtomType - -nameAtomType :: AtomType -nameAtomType = TextAtomType +type Price = Double -priceAtomType :: AtomType -priceAtomType = DoubleAtomType +type Name = T.Text -fileNameAtomType :: AtomType -fileNameAtomType = TextAtomType +type Address = T.Text -data Room = Kitchen | Bathroom | LivingRoom +data RoomType = Kitchen | Bathroom | LivingRoom deriving (Generic, Atomable, Eq, Show, Binary, NFData) -roomAtomType :: AtomType -roomAtomType = toAtomType (undefined :: Room) - data PriceBand = Low | Medium | High | Premium deriving (Generic, Atomable, Eq, Show, Binary, NFData) -priceBandAtomType :: AtomType -priceBandAtomType = toAtomType (undefined :: PriceBand) - data AreaCode = City | Suburban | Rural deriving (Generic, Atomable, Eq, Show, Binary, NFData) -areaCodeAtomType :: AtomType -areaCodeAtomType = ConstructedAtomType "AreaCode" M.empty - data SpeedBand = VeryFastBand | FastBand | MediumBand | SlowBand deriving (Generic, Atomable, Eq, Show, Binary, NFData) -speedBandAtomType :: AtomType -speedBandAtomType = ConstructedAtomType "SpeedBand" M.empty - main :: IO () main = do --connect to the database @@ -57,81 +42,117 @@ let conn = check eConn --create a database session at the default branch of the fresh database - eSessionId <- createSessionAtHead "master" conn + eSessionId <- createSessionAtHead conn "master" let sessionId = check eSessionId createSchema sessionId conn + insertSampleData sessionId conn +data Property = Property { + address :: T.Text, + price :: Price, + photo :: T.Text, + dateRegistered :: Day + } + deriving (Generic, Eq, Show) + +instance Tupleable Property + +data Offer = Offer { + offerAddress :: Address, + offerPrice :: Price, + offerDate :: Day, + bidderName :: Name, + bidderAddress :: Address, + decisionDate :: Day, + accepted :: Bool + } + deriving (Generic, Eq) + +instance Tupleable Offer + +data Decision = Decision { + decAddress :: Address, + decOfferDate :: Day, --the dec prefix is needed until OverloadedRecordFields is available + decBidderName :: Name, + decBidderAddress :: Address, + decDecisionDate :: Day, + decAccepted :: Bool + } + deriving (Generic, Eq) + +instance Tupleable Decision + +data Room = Room { + roomAddress :: Address, + roomName :: Name, + width :: Double, + breadth :: Double, + roomType :: RoomType + } + deriving (Generic, Eq) + +instance Tupleable Room + +data Floor = Floor { + floorAddress :: Address, + floorRoomName :: Name, + floorNum :: Int + } + deriving (Generic, Eq) + +instance Tupleable Floor + +data Commission = Commission { + priceBand :: PriceBand, + areaCode :: AreaCode, + saleSpeed :: SpeedBand, + commission :: Price + } deriving (Generic, Eq) + +instance Tupleable Commission + createSchema :: SessionId -> Connection -> IO () createSchema sessionId conn = do --create attributes for relvars - let propertyAttrs = [Attribute "address" addressAtomType, - Attribute "price" priceAtomType, - Attribute "photo" fileNameAtomType, - Attribute "dateRegistered" DayAtomType] - offerAttrs = [Attribute "address" addressAtomType, - Attribute "offerPrice" priceAtomType, - Attribute "offerDate" DayAtomType, - Attribute "bidderName" nameAtomType, - Attribute "bidderAddress" addressAtomType, - Attribute "decisionDate" DayAtomType, - Attribute "accepted" BoolAtomType] - decisionAttrs = [Attribute "address" addressAtomType, - Attribute "offerDate" DayAtomType, - Attribute "bidderName" nameAtomType, - Attribute "bidderAddress" addressAtomType, - Attribute "decisionDate" DayAtomType, - Attribute "accepted" BoolAtomType] - roomAttrs = [Attribute "address" addressAtomType, - Attribute "roomName" TextAtomType, - Attribute "width" DoubleAtomType, - Attribute "breadth" DoubleAtomType, - Attribute "type" roomAtomType] - floorAttrs = [Attribute "address" addressAtomType, - Attribute "roomName" TextAtomType, - Attribute "floor" IntAtomType] - commissionAttrs = [Attribute "priceBand" priceBandAtomType, - Attribute "areaCode" areaCodeAtomType, - Attribute "saleSpeed" speedBandAtomType, - Attribute "commission" DoubleAtomType] + let --create uniqueness constraints incDepKeys = map (uncurry databaseContextExprForUniqueKey) [("property", ["address"]), - ("offer", ["address", "offerDate", "bidderName", "bidderAddress"]), - ("decision", ["address", "offerDate", "bidderName", "bidderAddress"]), - ("room", ["address", "roomName"]), - ("floor", ["address", "roomName"]), + ("offer", ["offerAddress", "offerDate", "bidderName", "bidderAddress"]), + ("decision", ["decAddress", "decOfferDate", "decBidderName", "decBidderAddress"]), + ("room", ["roomAddress", "roomName"]), + ("floor", ["floorAddress", "floorRoomName"]), --"commision" misspelled in OotT ("commission", ["priceBand", "areaCode", "saleSpeed"]) ] --create foreign key constraints foreignKeys = [("offer_property_fk", - ("offer", ["address"]), + ("offer", ["offerAddress"]), ("property", ["address"])), ("decision_offer_fk", - ("decision", ["address", "offerDate", "bidderName", "bidderAddress"]), - ("offer", ["address", "offerDate", "bidderName", "bidderAddress"])), + ("decision", ["decAddress", "decOfferDate", "decBidderName", "decBidderAddress"]), + ("offer", ["offerAddress", "offerDate", "bidderName", "bidderAddress"])), ("room_property_fk", - ("room", ["address"]), + ("room", ["roomAddress"]), ("property", ["address"])), ("floor_property_fk", - ("floor", ["address"]), + ("floor", ["floorAddress"]), ("property", ["address"])) ] incDepForeignKeys = map (\(n, a, b) -> databaseContextExprForForeignKey n a b) foreignKeys --define the relvars - relvarMap = [("property", propertyAttrs), - ("offer", offerAttrs), - ("decision", decisionAttrs), - ("room", roomAttrs), - ("floor", floorAttrs), - ("commission", commissionAttrs)] - rvDefs = map (\(name, attrs) -> Define name (map NakedAttributeExpr attrs)) relvarMap + rvExprs = [toDefineExpr (undefined :: Property) "property", + toDefineExpr (undefined :: Offer) "offer", + toDefineExpr (undefined :: Decision) "decision", + toDefineExpr (undefined :: Room) "room", + toDefineExpr (undefined :: Floor) "floor", + toDefineExpr (undefined :: Commission) "commission"] --create the new algebraic data types - new_adts = [toDatabaseContextExpr (undefined :: Room), - toDatabaseContextExpr (undefined :: PriceBand), - toDatabaseContextExpr (undefined :: AreaCode), - toDatabaseContextExpr (undefined :: SpeedBand)] + new_adts = [toAddTypeExpr (undefined :: RoomType), + toAddTypeExpr (undefined :: PriceBand), + toAddTypeExpr (undefined :: AreaCode), + toAddTypeExpr (undefined :: SpeedBand)] --create the stored atom functions priceBandScript = "(\\(DoubleAtom price:_) -> do\n let band = if price < 10000.0 then \"Low\" else if price < 20000.0 then \"Medium\" else if price < 30000.0 then \"High\" else \"Premium\"\n let aType = ConstructedAtomType \"PriceBand\" empty\n pure (ConstructedAtom band aType [])) :: [Atom] -> Either AtomFunctionError Atom" areaCodeScript = "(\\(TextAtom address:_) -> let aType = ConstructedAtomType \"AreaCode\" empty in if address == \"90210\" then pure (ConstructedAtom \"City\" aType []) else pure (ConstructedAtom \"Rural\" aType [])) :: [Atom] -> Either AtomFunctionError Atom" @@ -141,10 +162,98 @@ createScriptedAtomFunction "datesToSpeedBand" [dayTypeConstructor, dayTypeConstructor] (ADTypeConstructor "SpeedBand" []) speedBandScript ] --gather up and execute all database updates - mErrs <- mapM (executeDatabaseContextExpr sessionId conn) (new_adts ++ rvDefs ++ incDepKeys ++ incDepForeignKeys) - let errs = catMaybes mErrs - when (length errs > 0) (error (show errs)) + putStrLn "load relvars" + _ <- handleIOErrors $ mapM (executeDatabaseContextExpr sessionId conn) (new_adts ++ rvExprs ++ incDepKeys ++ incDepForeignKeys) - mErrs' <- mapM (executeDatabaseContextIOExpr sessionId conn) atomFuncs - let errs' = catMaybes mErrs' - when (length errs' > 0) (error (show errs')) + putStrLn "load atom functions" + _ <- handleIOErrors $ mapM (executeDatabaseContextIOExpr sessionId conn) atomFuncs + pure () + +insertSampleData :: SessionId -> Connection -> IO () +insertSampleData sessionId conn = do + --insert a bunch of records + putStrLn "load data" + let properties = [Property { address = "123 Main St.", + price = 200000, + photo = "123_main.jpg", + dateRegistered = fromGregorian 2016 4 3}, + Property { address = "456 Main St.", + price = 150000, + photo = "456_main.jpg", + dateRegistered = fromGregorian 2016 5 6}] + insertPropertiesExpr <- handleError $ toInsertExpr properties "property" + handleIOError $ executeDatabaseContextExpr sessionId conn insertPropertiesExpr + + let offers = [Offer { offerAddress = "123 Main St.", + offerPrice = 180000, + offerDate = fromGregorian 2017 1 2, + bidderName = "Steve", + bidderAddress = "789 Main St.", + decisionDate = fromGregorian 2017 2 2, + accepted = False }] + + insertOffersExpr <- handleError $ toInsertExpr offers "offer" + handleIOError $ executeDatabaseContextExpr sessionId conn insertOffersExpr + + let rooms = [Room { roomAddress = "123 Main St.", + roomName = "Fabulous Kitchen", + width = 10, + breadth = 10, + roomType = Kitchen }, + Room { roomAddress = "123 Main St.", + roomName = "Clean Bathroom", + width = 7, + breadth = 5, + roomType = Bathroom }] + + insertRoomsExpr <- handleError $ toInsertExpr rooms "room" + handleIOError $ executeDatabaseContextExpr sessionId conn insertRoomsExpr + + let decisions = [Decision { decAddress = "123 Main St.", + decOfferDate = fromGregorian 2017 1 2, + decBidderName = "Steve", + decBidderAddress = "789 Main St.", + decDecisionDate = fromGregorian 2017 05 04, + decAccepted = False }] + insertDecisionsExpr <- handleError $ toInsertExpr decisions "decision" + handleIOError $ executeDatabaseContextExpr sessionId conn insertDecisionsExpr + + let floors = [Floor { floorAddress = "123 Main St.", + floorRoomName = "Bathroom", + floorNum = 1 + }] + insertFloorsExpr <- handleError $ toInsertExpr floors "floor" + handleIOError $ executeDatabaseContextExpr sessionId conn insertFloorsExpr + + let commissions = [Commission { priceBand = Medium, + areaCode = City, + saleSpeed = MediumBand, + commission = 10000 }] + insertCommissionsExpr <- handleError $ toInsertExpr commissions "commission" + handleIOError $ executeDatabaseContextExpr sessionId conn insertCommissionsExpr + + --query some records, marshal them back to Haskell + + properties' <- handleIOError $ executeRelationalExpr sessionId conn (RelationVariable "property" ()) + + props <- toList properties' >>= mapM (handleError . fromTuple) :: IO [Property] + print props + +handleError :: Either RelationalError a -> IO a +handleError eErr = case eErr of + Left err -> print err >> error "Died due to errors." + Right v -> pure v + +handleIOError :: IO (Either RelationalError a) -> IO a +handleIOError m = do + e <- m + handleError e + +handleIOErrors :: IO [Either RelationalError a] -> IO [a] +handleIOErrors m = do + eErrs <- m + case lefts eErrs of + [] -> pure (rights eErrs) + errs -> handleError (Left (someErrors errs)) + + diff --git a/project-m36.cabal b/project-m36.cabal --- a/project-m36.cabal +++ b/project-m36.cabal @@ -1,5 +1,5 @@ Name: project-m36 -Version: 0.1 +Version: 0.2 License: PublicDomain Build-Type: Simple Homepage: https://github.com/agentm/project-m36 @@ -20,11 +20,11 @@ Flag profiler Description: Enable Haskell-specific profiling support Default: False - Manual: True + Manual: True Library - Build-Depends: base>=4.8 && < 5.0 - ,ghc >= 7.8 && <= 8.1 + Build-Depends: base>=4.8 && < 6.0 + ,ghc >= 7.8 && < 8.3 ,ghc-paths ,mtl ,containers @@ -34,9 +34,9 @@ ,directory ,MonadRandom ,random-shuffle - --critical uuid bug in lesser versions https://www.reddit.com/r/haskell/comments/4myot5/psa_make_sure_to_use_uuid_1312/ + --critical uuid bug in lesser versions https://www.reddit.com/r/haskell/comments/4myot5/psa_make_sure_to_use_uuid_1312/ ,uuid >= 1.3.12 - ,cassava ==0.4.* + ,cassava >= 0.4.5.1 && < 0.6 ,text ,bytestring ,deepseq @@ -61,20 +61,21 @@ ,data-interval ,extended-reals ,network-transport - ,aeson + -- aeson 1.1 and above includes instances for UUID types + ,aeson >= 1.1 ,path-pieces ,conduit ,resourcet ,http-api-data ---needed for remote access +--needed for remote access ,distributed-process-client-server >= 0.2.3 ,distributed-process >= 0.6.6 ,distributed-process-extras >= 0.3.2 ,distributed-process-async >= 0.2.4 ,network-transport-tcp ,network-transport - ,stm-containers ,list-t + ,stm-containers >= 0.2.15 ,optparse-applicative ,Glob --used for hashing the transaction graph file to check for differences @@ -97,12 +98,13 @@ ProjectM36.ScriptSession, ProjectM36.DatabaseContextFunction, ProjectM36.DatabaseContextFunctionError, + ProjectM36.DatabaseContextFunctionUtils, ProjectM36.Key, ProjectM36.FunctionalDependency, ProjectM36.DatabaseContext, ProjectM36.DateExamples, ProjectM36.DisconnectedTransaction, - ProjectM36.AtomFunctionBody, + ProjectM36.AtomFunctionBody, ProjectM36.RelationalExpression, ProjectM36.Relation.Show.HTML, ProjectM36.StaticOptimizer, @@ -113,11 +115,13 @@ ProjectM36.IsomorphicSchema, ProjectM36.InclusionDependency, ProjectM36.Client, + ProjectM36.Client.Simple, ProjectM36.Persist, ProjectM36.AtomType, ProjectM36.AtomFunctions.Basic, ProjectM36.AtomFunctions.Primitive, ProjectM36.Atomable, + ProjectM36.Tupleable, ProjectM36.DataConstructorDef, ProjectM36.DataTypes.Basic, ProjectM36.DataTypes.Day, @@ -126,6 +130,8 @@ ProjectM36.DataTypes.Maybe, ProjectM36.DataTypes.List, ProjectM36.DataTypes.Primitive, + ProjectM36.DataTypes.Interval, + ProjectM36.DataTypes.ByteString, ProjectM36.MiscUtils, ProjectM36.Notifications, ProjectM36.Relation, @@ -156,10 +162,10 @@ ghc-boot Executable tutd - Build-Depends: base >=4.8 && <5.0, - ghc >= 7.8 && <= 8.1, + Build-Depends: base >=4.8 && <5.0, + ghc >= 7.8 && < 8.3, ghc-paths, - project-m36 == 0.1, + project-m36, containers, unordered-containers, hashable, @@ -185,7 +191,7 @@ directory, filepath, temporary, - megaparsec >= 5.2.0 && < 5.3, + megaparsec >= 5.2.0 && < 5.4, haskeline, random, MonadRandom, base64-bytestring, @@ -198,8 +204,6 @@ TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.TransactionGraphOperator, - TutorialD.Interpreter.DataTypes.Interval, - TutorialD.Interpreter.DataTypes.DateTime, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.Export.Base, @@ -214,9 +218,8 @@ TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator main-is: TutorialD/tutd.hs - CPP-Options: -DPROJECTM36_VERSION="v0.1" CC-Options: -fPIC - GHC-Options: -Wall + GHC-Options: -Wall Hs-Source-Dirs: ./src/bin Default-Language: Haskell2010 Default-Extensions: OverloadedStrings @@ -226,13 +229,13 @@ -- else -- C-sources: ProjectM36/DirectoryFsync.c -- Build-Depends: unix - + Executable project-m36-server Build-Depends: base, - ghc >= 7.8 && <= 8.1, + ghc >= 7.8 && < 8.3, ghc-paths, - project-m36 == 0.1, + project-m36, binary, transformers, temporary, @@ -260,7 +263,6 @@ list-t, base64-bytestring Main-Is: ./src/bin/ProjectM36/Server/project-m36-server.hs - CPP-Options: -DPROJECTM36_VERSION="v0.1" GHC-Options: -Wall -threaded -rtsopts if flag(profiler) GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall @@ -270,14 +272,13 @@ Executable bigrel Default-Language: Haskell2010 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, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36 == 0.1, random, MonadRandom, semigroups + 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, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types main-is: benchmark/bigrel.hs GHC-Options: -Wall -threaded -rtsopts - CPP-Options: -DPROJECTM36_VERSION="v0.1" HS-Source-Dirs: ./src/bin if flag(profiler) GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall @@ -287,11 +288,10 @@ Default-Extensions: OverloadedStrings type: exitcode-stdio-1.0 main-is: test/TutorialD/Interpreter.hs - 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, stm-containers, list-t, project-m36 == 0.1, random, MonadRandom, semigroups + 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, stm-containers, list-t, project-m36, random, MonadRandom, semigroups Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator GHC-Options: -Wall Hs-Source-Dirs: ./src/bin, ., test - CPP-Options: -DPROJECTM36_VERSION="v0.1" Test-Suite test-tutoriald-atomfunctionscript Default-Language: Haskell2010 @@ -299,10 +299,9 @@ type: exitcode-stdio-1.0 Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator main-is: test/TutorialD/Interpreter/AtomFunctionScript.hs - Build-Depends: base, HUnit, project-m36 == 0.1, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom, semigroups + Build-Depends: base, HUnit, project-m36, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom, semigroups, time GHC-Options: -Wall Hs-Source-Dirs: ./src/bin, ./test, . - CPP-Options: -DPROJECTM36_VERSION="v0.1" Test-Suite test-tutoriald-databasecontextfunctionscript Default-Language: Haskell2010 @@ -310,17 +309,16 @@ type: exitcode-stdio-1.0 Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator main-is: test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs - Build-Depends: base, HUnit, project-m36 == 0.1, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom, semigroups + Build-Depends: base, HUnit, project-m36, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom, semigroups, time GHC-Options: -Wall Hs-Source-Dirs: ./src/bin, ./test, . - CPP-Options: -DPROJECTM36_VERSION="v0.1" Test-Suite test-relation Default-Language: Haskell2010 Default-Extensions: OverloadedStrings type: exitcode-stdio-1.0 main-is: test/Relation/Basic.hs - 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, stm-containers, project-m36 == 0.1, transformers + 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, stm-containers, project-m36, transformers GHC-Options: -Wall Test-Suite test-static-optimizer @@ -328,16 +326,15 @@ Default-Extensions: OverloadedStrings type: exitcode-stdio-1.0 main-is: test/Relation/StaticOptimizer.hs - 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, stm-containers, project-m36 == 0.1, transformers + 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, stm-containers, project-m36, transformers GHC-Options: -Wall - CPP-Options: -DPROJECTM36_VERSION="v0.1" Test-Suite test-transactiongraph-persist Default-Language: Haskell2010 Default-Extensions: OverloadedStrings type: exitcode-stdio-1.0 main-is: test/TransactionGraph/Persist.hs - 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, stm-containers, project-m36 == 0.1, random, MonadRandom, semigroups + 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, stm-containers, project-m36, random, MonadRandom, semigroups Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples Hs-Source-Dirs: ., ./src/bin GHC-Options: -Wall @@ -347,16 +344,15 @@ Default-Extensions: OverloadedStrings type: exitcode-stdio-1.0 main-is: test/Relation/Import/CSV.hs - 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, stm-containers, project-m36 == 0.1 + 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, stm-containers, project-m36 GHC-Options: -Wall - CPP-Options: -DPROJECTM36_VERSION="v0.1" Test-Suite test-tutoriald-import-tutoriald Default-Language: Haskell2010 Default-Extensions: OverloadedStrings type: exitcode-stdio-1.0 main-is: test/TutorialD/Interpreter/Import/TutorialD.hs - 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, stm-containers, project-m36 == 0.1, random, MonadRandom, semigroups + 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, stm-containers, project-m36, random, MonadRandom, semigroups Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples GHC-Options: -Wall Hs-Source-Dirs: ., ./src/bin @@ -366,15 +362,15 @@ Default-Extensions: OverloadedStrings type: exitcode-stdio-1.0 main-is: test/Relation/Export/CSV.hs - 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, stm-containers, project-m36 == 0.1 - GHC-Options: -Wall + 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, stm-containers, project-m36 + GHC-Options: -Wall Test-Suite test-transactiongraph-merge Default-Language: Haskell2010 Default-Extensions: OverloadedStrings type: exitcode-stdio-1.0 main-is: test/TransactionGraph/Merge.hs - 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, template-haskell, transformers, aeson, conduit, either, path-pieces, http-api-data, stm-containers, list-t, project-m36 == 0.1 + 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, template-haskell, transformers, aeson, conduit, either, path-pieces, http-api-data, stm-containers, list-t, project-m36 GHC-Options: -Wall benchmark bench @@ -382,7 +378,7 @@ Default-Extensions: OverloadedStrings type: exitcode-stdio-1.0 main-is: benchmark/Relation.hs - 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, criterion, stm-containers, project-m36 == 0.1 + 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, criterion, stm-containers, project-m36 GHC-Options: -Wall -rtsopts Hs-Source-Dirs: ./src/bin @@ -391,50 +387,55 @@ Default-Extensions: OverloadedStrings type: exitcode-stdio-1.0 main-is: test/Server/Main.hs - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, 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, project-m36 == 0.1, network-transport, semigroups + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, 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, project-m36, network-transport, semigroups HS-Source-Dirs: ., ./src/bin GHC-Options: -Wall - + Executable Example-SimpleClient Default-Language: Haskell2010 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, ghc, ghc-paths, project-m36 == 0.1, random, MonadRandom + 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, ghc, ghc-paths, project-m36, random, MonadRandom Main-Is: examples/SimpleClient.hs GHC-Options: -Wall Executable Example-OutOfTheTarpit Default-Language: Haskell2010 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 == 0.1 + 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/out_of_the_tarpit.hs GHC-Options: -Wall - CPP-Options: -DPROJECTM36_VERSION="v0.1" +Executable Example-Blog + Default-Language: Haskell2010 + 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/blog.hs + GHC-Options: -Wall + + Executable Example-Hair Default-Language: Haskell2010 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 == 0.1 + 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/hair.hs GHC-Options: -Wall - CPP-Options: -DPROJECTM36_VERSION="v0.1" - + Test-Suite test-scripts Default-Language: Haskell2010 Default-Extensions: OverloadedStrings type: exitcode-stdio-1.0 main-is: test/scripts.hs - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, 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, project-m36 == 0.1, random, MonadRandom, semigroups + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, 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, project-m36, random, MonadRandom, semigroups Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.Import.BasicExamples GHC-Options: -Wall Hs-Source-Dirs: ., ./src/bin Executable project-m36-websocket-server Default-Language: Haskell2010 - Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, uuid-aeson, optparse-applicative, project-m36 == 0.1, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, network-transport-tcp, semigroups + Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, optparse-applicative, project-m36, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, network-transport-tcp, semigroups Main-Is: ProjectM36/Server/WebSocket/websocket-server.hs Other-Modules: ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator - GHC-Options: -Wall - CPP-Options: -DPROJECTM36_VERSION="v0.1" + GHC-Options: -Wall Hs-Source-Dirs: ./src/bin Default-Extensions: OverloadedStrings @@ -442,41 +443,64 @@ Default-Language: Haskell2010 type: exitcode-stdio-1.0 main-is: test/Server/WebSocket.hs - 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, websockets, optparse-applicative, network, aeson, uuid-aeson, project-m36 == 0.1, random, MonadRandom, network-transport-tcp, semigroups + 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, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, network-transport-tcp, semigroups Other-Modules: TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.TransactionGraphOperator, ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator Default-Extensions: OverloadedStrings GHC-Options: -Wall Hs-Source-Dirs: ./src/bin, . - CPP-Options: -DPROJECTM36_VERSION="v0.1" Test-Suite test-isomorphic-schemas Default-Language: Haskell2010 type: exitcode-stdio-1.0 main-is: test/IsomorphicSchema.hs - 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, websockets, optparse-applicative, network, aeson, uuid-aeson, project-m36 == 0.1 + 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, websockets, optparse-applicative, network, aeson, project-m36 Default-Extensions: OverloadedStrings GHC-Options: -Wall Hs-Source-Dirs: ./src/bin, . - CPP-Options: -DPROJECTM36_VERSION="v0.1" Test-Suite test-atomable Default-Language: Haskell2010 type: exitcode-stdio-1.0 main-is: test/Relation/Atomable.hs - 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, websockets, optparse-applicative, network, aeson, uuid-aeson, project-m36 == 0.1, random, MonadRandom, semigroups + 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, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types Default-Extensions: OverloadedStrings GHC-Options: -Wall Hs-Source-Dirs: ./src/bin, ., test/ - CPP-Options: -DPROJECTM36_VERSION="v0.1" Test-Suite test-multiprocess-access Default-Language: Haskell2010 type: exitcode-stdio-1.0 main-is: test/MultiProcessDatabaseAccess.hs - 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, websockets, optparse-applicative, network, aeson, uuid-aeson, project-m36 == 0.1, random, MonadRandom + 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, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom Default-Extensions: OverloadedStrings GHC-Options: -Wall Hs-Source-Dirs: ./src/bin, ., test/ - CPP-Options: -DPROJECTM36_VERSION="v0.1" - + +Test-Suite test-transactiongraph-automerge + Default-Language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: test/TransactionGraph/Automerge.hs + 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, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups + Default-Extensions: OverloadedStrings + GHC-Options: -Wall + Hs-Source-Dirs: ./src/bin, ., test/ + +Test-Suite test-tupleable + Default-Language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: test/Relation/Tupleable.hs + 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, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups + Default-Extensions: OverloadedStrings + GHC-Options: -Wall + Hs-Source-Dirs: ./src/bin, ., test/ + +Test-Suite test-client-simple + Default-Language: Haskell2010 + Main-Is: test/Client/Simple.hs + type: exitcode-stdio-1.0 + 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, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups + Default-Extensions: OverloadedStrings + GHC-Options: -Wall + Hs-Source-Dirs: ./src/bin, ., test/ + diff --git a/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs b/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs --- a/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs +++ b/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs @@ -1,18 +1,16 @@ --create a bunch of orphan instances for use with the websocket server -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module ProjectM36.Server.RemoteCallTypes.Json where -import ProjectM36.Server.RemoteCallTypes +import ProjectM36.AtomFunctionError import ProjectM36.Base -import ProjectM36.Error +import ProjectM36.DatabaseContextFunctionError import ProjectM36.DataTypes.Primitive +import ProjectM36.Error import ProjectM36.IsomorphicSchema -import ProjectM36.DatabaseContextFunctionError -import ProjectM36.AtomFunctionError +import ProjectM36.Server.RemoteCallTypes -import Control.Monad import Data.Aeson -import Data.UUID.Aeson () import Data.ByteString.Base64 as B64 import Data.Text.Encoding import Data.Time.Calendar @@ -65,22 +63,30 @@ instance ToJSON SchemaIsomorph instance FromJSON SchemaIsomorph -instance ToJSON Atom where +instance ToJSON Atom where toJSON atom@(IntAtom i) = object [ "type" .= atomTypeForAtom atom, "val" .= i ] toJSON atom@(DoubleAtom i) = object [ "type" .= atomTypeForAtom atom, "val" .= i ] toJSON atom@(TextAtom i) = object [ "type" .= atomTypeForAtom atom, "val" .= i ] - toJSON atom@(DayAtom i) = do - object [ "type" .= atomTypeForAtom atom, - "val" .= toGregorian i ] + toJSON atom@(DayAtom i) = object [ "type" .= atomTypeForAtom atom, + "val" .= toGregorian i ] toJSON atom@(DateTimeAtom i) = object [ "type" .= atomTypeForAtom atom, "val" .= i ] toJSON atom@(ByteStringAtom i) = object [ "type" .= atomTypeForAtom atom, "val" .= decodeUtf8 (B64.encode i) ] toJSON atom@(BoolAtom i) = object [ "type" .= atomTypeForAtom atom, "val" .= i ] + + toJSON atom@(IntervalAtom b e i1 i2) = object [ "type" .= atomTypeForAtom atom, + "val" .= object [ + "begin" .= toJSON b, + "end" .= toJSON e, + "beginopen" .= i1, + "endopen" .= i2 + ] + ] toJSON atom@(RelationAtom i) = object [ "type" .= atomTypeForAtom atom, "val" .= i ] toJSON (ConstructedAtom dConsName atomtype atomlist) = object [ @@ -88,16 +94,16 @@ "type" .= toJSON atomtype, "atomlist" .= toJSON atomlist ] - + instance FromJSON Atom where parseJSON = withObject "atom" $ \o -> do - atype <- o .: "type" + atype <- o .: "type" case atype of - TypeVariableType _ -> fail "cannot pass AnyAtomType over the wire" + TypeVariableType _ -> fail "cannot pass TypeVariableType over the wire" caType@(ConstructedAtomType _ _) -> ConstructedAtom <$> o .: "dataconstructorname" <*> pure caType <*> o .: "atom" RelationAtomType _ -> do rel <- o .: "val" - pure $ RelationAtom rel + pure $ RelationAtom rel IntAtomType -> IntAtom <$> o .: "val" DoubleAtomType -> DoubleAtom <$> o .: "val" TextAtomType -> TextAtom <$> o .: "val" @@ -106,11 +112,17 @@ pure (DayAtom (fromGregorian y m d)) DateTimeAtomType -> DateTimeAtom <$> o .: "val" ByteStringAtomType -> do - b64bs <- liftM encodeUtf8 (o .: "val") + b64bs <- fmap encodeUtf8 (o .: "val") case B64.decode b64bs of Left err -> fail ("Failed to parse base64-encoded ByteString: " ++ err) Right bs -> pure (ByteStringAtom bs) BoolAtomType -> BoolAtom <$> o .: "val" + IntervalAtomType _ -> IntervalAtom <$> + ((o .: "val") >>= (.: "begin")) <*> + ((o .: "val") >>= (.: "end")) <*> + ((o .: "val") >>= (.: "beginopen")) <*> + ((o .: "val") >>= (.: "endopen")) + instance ToJSON Notification instance FromJSON Notification diff --git a/src/bin/ProjectM36/Server/WebSocket.hs b/src/bin/ProjectM36/Server/WebSocket.hs --- a/src/bin/ProjectM36/Server/WebSocket.hs +++ b/src/bin/ProjectM36/Server/WebSocket.hs @@ -14,14 +14,13 @@ import TutorialD.Interpreter.Base import ProjectM36.Client import Control.Exception -import Data.Maybe (fromMaybe) websocketProxyServer :: Port -> Hostname -> WS.ServerApp websocketProxyServer port host pending = do conn <- WS.acceptRequest pending let unexpectedMsg = WS.sendTextData conn ("messagenotexpected" :: T.Text) --phase 1- accept database name for connection - dbmsg <- (WS.receiveData conn) :: IO T.Text + dbmsg <- WS.receiveData conn :: IO T.Text let connectdbmsg = "connectdb:" if not (connectdbmsg `T.isPrefixOf` dbmsg) then unexpectedMsg >> WS.sendClose conn ("" :: T.Text) else do @@ -29,11 +28,11 @@ bracket (createConnection conn dbname port host) (\eDBconn -> case eDBconn of Right dbconn -> close dbconn - Left _ -> pure ()) $ \eDBconn -> do + Left _ -> pure ()) $ \eDBconn -> case eDBconn of Left err -> sendError conn err Right dbconn -> do - eSessionId <- createSessionAtHead "master" dbconn + eSessionId <- createSessionAtHead dbconn "master" case eSessionId of Left err -> sendError conn err Right sessionId -> do @@ -43,7 +42,7 @@ --figure out why sending three times during startup is necessary sendPromptInfo pInfo conn sendPromptInfo pInfo conn - msg <- (WS.receiveData conn) :: IO T.Text + msg <- WS.receiveData conn :: IO T.Text let tutdprefix = "executetutd:" case msg of _ | tutdprefix `T.isPrefixOf` msg -> do @@ -51,7 +50,7 @@ case parseTutorialD tutdString of Left err -> handleOpResult conn dbconn (DisplayErrorResult ("parse error: " `T.append` T.pack (show err))) Right parsed -> do - let timeoutFilter = \exc -> if exc == RequestTimeoutException + let timeoutFilter exc = if exc == RequestTimeoutException then Just exc else Nothing responseHandler = do @@ -87,9 +86,9 @@ -- get current schema and head name for client promptInfo :: SessionId -> Connection -> IO (HeadName, SchemaName) promptInfo sessionId conn = do - mHeadName <- headName sessionId conn - mSchemaName <- currentSchemaName sessionId conn - pure (fromMaybe "" mHeadName, fromMaybe "" mSchemaName) + eHeadName <- headName sessionId conn + eSchemaName <- currentSchemaName sessionId conn + pure (either (const "") id eHeadName, either (const "") id eSchemaName) sendPromptInfo :: (HeadName, SchemaName) -> WS.Connection -> IO () sendPromptInfo (hName, sName) conn = WS.sendTextData conn (encode (object ["promptInfo" .= object ["headname" .= hName, "schemaname" .= sName]])) diff --git a/src/bin/TutorialD/Interpreter.hs b/src/bin/TutorialD/Interpreter.hs --- a/src/bin/TutorialD/Interpreter.hs +++ b/src/bin/TutorialD/Interpreter.hs @@ -18,6 +18,7 @@ import TutorialD.Interpreter.Export.Base import ProjectM36.Base +import ProjectM36.Error import ProjectM36.Relation.Show.Term import ProjectM36.TransactionGraph import qualified ProjectM36.Client as C @@ -25,11 +26,9 @@ import Text.Megaparsec import Text.Megaparsec.Text -import Control.Monad.State import System.Console.Haskeline import System.Directory (getHomeDirectory) import qualified Data.Text as T -import Data.Maybe (fromMaybe) import System.IO (hPutStrLn, stderr) import Data.Monoid import Control.Exception @@ -44,6 +43,7 @@ DatabaseContextIOExprOp DatabaseContextIOExpr | InfoOp InformationOperator | GraphOp TransactionGraphOperator | + ConvenienceGraphOp ConvenienceTransactionGraphOperator | ROGraphOp ROTransactionGraphOperator | ImportRelVarOp RelVarDataImportOperator | ImportDBContextOp DatabaseContextDataImportOperator | @@ -55,65 +55,59 @@ interpreterParserP :: Parser ParsedOperation interpreterParserP = safeInterpreterParserP <|> - liftM ImportRelVarOp (importCSVP <* eof) <|> - liftM ImportDBContextOp (tutdImportP <* eof) <|> - liftM RelVarExportOp (exportCSVP <* eof) <|> - liftM DatabaseContextIOExprOp (dbContextIOExprP <* eof) + fmap ImportRelVarOp (importCSVP <* eof) <|> + fmap ImportDBContextOp (tutdImportP <* eof) <|> + fmap RelVarExportOp (exportCSVP <* eof) <|> + fmap DatabaseContextIOExprOp (dbContextIOExprP <* eof) -- the safe interpreter never reads or writes the file system safeInterpreterParserP :: Parser ParsedOperation -safeInterpreterParserP = liftM RODatabaseContextOp (roDatabaseContextOperatorP <* eof) <|> - liftM InfoOp (infoOpP <* eof) <|> - liftM GraphOp (transactionGraphOpP <* eof) <|> - liftM ROGraphOp (roTransactionGraphOpP <* eof) <|> - liftM DatabaseContextExprOp (databaseExprOpP <* eof) <|> - liftM ImportBasicExampleOp (importBasicExampleOperatorP <* eof) <|> - liftM TransGraphRelationalOp (transGraphRelationalOpP <* eof) <|> - liftM SchemaOp (schemaOperatorP <* eof) +safeInterpreterParserP = fmap RODatabaseContextOp (roDatabaseContextOperatorP <* eof) <|> + fmap InfoOp (infoOpP <* eof) <|> + fmap GraphOp (transactionGraphOpP <* eof) <|> + fmap ConvenienceGraphOp (convenienceTransactionGraphOpP <* eof) <|> + fmap ROGraphOp (roTransactionGraphOpP <* eof) <|> + fmap DatabaseContextExprOp (databaseExprOpP <* eof) <|> + fmap ImportBasicExampleOp (importBasicExampleOperatorP <* eof) <|> + fmap TransGraphRelationalOp (transGraphRelationalOpP <* eof) <|> + fmap SchemaOp (schemaOperatorP <* eof) -promptText :: Maybe HeadName -> Maybe SchemaName -> StringType -promptText mHeadName mSchemaName = "TutorialD (" <> transInfo <> "): " +promptText :: Either RelationalError HeadName -> Either RelationalError SchemaName -> StringType +promptText eHeadName eSchemaName = "TutorialD (" <> transInfo <> "): " where - transInfo = fromMaybe "" mHeadName <> "/" <> fromMaybe "" mSchemaName + transInfo = either (const "") id eHeadName <> "/" <> either (const "") id eSchemaName parseTutorialD :: T.Text -> Either (ParseError Char Dec) ParsedOperation -parseTutorialD inputString = parse interpreterParserP "" inputString +parseTutorialD = parse interpreterParserP "" --only parse tutoriald which doesn't result in file I/O safeParseTutorialD :: T.Text -> Either (ParseError Char Dec) ParsedOperation -safeParseTutorialD inputString = parse safeInterpreterParserP "" inputString +safeParseTutorialD = parse safeInterpreterParserP "" data SafeEvaluationFlag = SafeEvaluation | UnsafeEvaluation deriving (Eq) --execute the operation and display result -evalTutorialD :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> ParsedOperation -> IO (TutorialDOperatorResult) +evalTutorialD :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> ParsedOperation -> IO TutorialDOperatorResult evalTutorialD sessionId conn safe expr = case expr of - --this does not pass through the ProjectM36.Client library because the operations --are specific to the interpreter, though some operations may be of general use in the future - (RODatabaseContextOp execOp) -> do + (RODatabaseContextOp execOp) -> evalRODatabaseContextOp sessionId conn execOp - (DatabaseContextExprOp execOp) -> do - maybeErr <- C.executeDatabaseContextExpr sessionId conn execOp - case maybeErr of - Just err -> barf err - Nothing -> return QuietSuccessResult + (DatabaseContextExprOp execOp) -> + eHandler $ C.executeDatabaseContextExpr sessionId conn execOp - (DatabaseContextIOExprOp execOp) -> do + (DatabaseContextIOExprOp execOp) -> if needsSafe then unsafeError - else do - mErr <- C.executeDatabaseContextIOExpr sessionId conn execOp - case mErr of - Just err -> barf err - Nothing -> pure QuietSuccessResult + else + eHandler $ C.executeDatabaseContextIOExpr sessionId conn execOp - (GraphOp execOp) -> do - maybeErr <- C.executeGraphExpr sessionId conn execOp - case maybeErr of - Just err -> barf err - Nothing -> return QuietSuccessResult + (GraphOp execOp) -> + eHandler $ C.executeGraphExpr sessionId conn execOp + + (ConvenienceGraphOp execOp) -> + eHandler $ evalConvenienceGraphOp sessionId conn execOp (ROGraphOp execOp) -> do opResult <- evalROGraphOp sessionId conn execOp @@ -121,13 +115,10 @@ Left err -> barf err Right rel -> pure (DisplayRelationResult rel) - (SchemaOp execOp) -> do - opResult <- evalSchemaOperator sessionId conn execOp - case opResult of - Just err -> barf err - Nothing -> pure QuietSuccessResult + (SchemaOp execOp) -> + eHandler $ evalSchemaOperator sessionId conn execOp - (ImportRelVarOp execOp@(RelVarDataImportOperator relVarName _ _)) -> do + (ImportRelVarOp execOp@(RelVarDataImportOperator relVarName _ _)) -> if needsSafe then unsafeError else do @@ -142,24 +133,24 @@ Left err -> barf err Right dbexpr -> evalTutorialD sessionId conn safe (DatabaseContextExprOp dbexpr) - (ImportDBContextOp execOp) -> do + (ImportDBContextOp execOp) -> if needsSafe then unsafeError else do - mDbexprs <- evalDatabaseContextDataImportOperator execOp - case mDbexprs of + eErr <- evalDatabaseContextDataImportOperator execOp + case eErr of Left err -> barf err Right dbexprs -> evalTutorialD sessionId conn safe (DatabaseContextExprOp dbexprs) - (InfoOp execOp) -> do + (InfoOp execOp) -> if needsSafe then unsafeError else case evalInformationOperator execOp of - Left err -> barf err + Left err -> pure (DisplayErrorResult err) Right info -> pure (DisplayResult info) - (RelVarExportOp execOp@(RelVarDataExportOperator relExpr _ _)) -> do + (RelVarExportOp execOp@(RelVarDataExportOperator relExpr _ _)) -> --eval relexpr to relation and pass to export function if needsSafe then unsafeError @@ -175,13 +166,20 @@ (ImportBasicExampleOp execOp) -> do let dbcontextexpr = evalImportBasicExampleOperator execOp evalTutorialD sessionId conn safe (DatabaseContextExprOp dbcontextexpr) - (TransGraphRelationalOp execOp) -> do + (TransGraphRelationalOp execOp) -> evalTransGraphRelationalOp sessionId conn execOp where needsSafe = safe == SafeEvaluation unsafeError = pure $ DisplayErrorResult "File I/O operation prohibited." + barf :: RelationalError -> IO TutorialDOperatorResult + barf (ScriptError (OtherScriptCompilationError errStr)) = pure (DisplayErrorResult (T.pack errStr)) barf err = return $ DisplayErrorResult (T.pack (show err)) - + eHandler io = do + eErr <- io + case eErr of + Left err -> barf err + Right () -> return QuietSuccessResult + type GhcPkgPath = String data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName [GhcPkgPath] | RemoteInterpreterConfig C.NodeId C.DatabaseName HeadName @@ -198,17 +196,17 @@ reprLoop config sessionId conn = do homeDirectory <- getHomeDirectory let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")} - mHeadName <- C.headName sessionId conn - mSchemaName <- C.currentSchemaName sessionId conn - let prompt = promptText mHeadName mSchemaName + eHeadName <- C.headName sessionId conn + eSchemaName <- C.currentSchemaName sessionId conn + let prompt = promptText eHeadName eSchemaName maybeLine <- runInputT settings $ getInputLine (T.unpack prompt) case maybeLine of Nothing -> return () Just line -> do case parseTutorialD (T.pack line) of - Left err -> do + Left err -> displayOpResult $ DisplayParseErrorResult (T.length prompt) err - Right parsed -> do + Right parsed -> catchJust (\exc -> if exc == C.RequestTimeoutException then Just exc else Nothing) (do evald <- evalTutorialD sessionId conn UnsafeEvaluation parsed displayOpResult evald) diff --git a/src/bin/TutorialD/Interpreter/Base.hs b/src/bin/TutorialD/Interpreter/Base.hs --- a/src/bin/TutorialD/Interpreter/Base.hs +++ b/src/bin/TutorialD/Interpreter/Base.hs @@ -1,10 +1,12 @@ {-# LANGUAGE DeriveGeneric, CPP #-} module TutorialD.Interpreter.Base where +import ProjectM36.Base +import ProjectM36.AtomType +import ProjectM36.Relation + import Text.Megaparsec import Text.Megaparsec.Text import qualified Text.Megaparsec.Lexer as Lex -import ProjectM36.Base -import ProjectM36.AtomType import Data.Text hiding (count) import System.Random import qualified Data.Text as T @@ -15,11 +17,11 @@ import ProjectM36.Relation.Show.Term import GHC.Generics import Data.Monoid -import Control.Monad (void) import qualified Data.UUID as U -import ProjectM36.Relation import Control.Monad.Random import Data.List.NonEmpty as NE +import Data.Time.Clock +import Data.Time.Format displayOpResult :: TutorialDOperatorResult -> IO () displayOpResult QuitResult = return () @@ -64,7 +66,7 @@ pure (pack (istart:irest)) symbol :: String -> Parser Text -symbol sym = pack <$> Lex.symbol spaceConsumer sym +symbol sym = pack <$> Lex.symbol spaceConsumer sym comma :: Parser Text comma = symbol "," @@ -98,6 +100,10 @@ capitalizedIdentifier :: Parser Text capitalizedIdentifier = do fletter <- upperChar + restOfIdentifier_ fletter + +restOfIdentifier_ :: Char -> Parser Text +restOfIdentifier_ fletter = do rest <- option "" identifier spaceConsumer pure (T.cons fletter rest) @@ -105,9 +111,7 @@ uncapitalizedIdentifier :: Parser Text uncapitalizedIdentifier = do fletter <- lowerChar - rest <- option "" identifier - spaceConsumer - pure (T.cons fletter rest) + restOfIdentifier_ fletter showRelationAttributes :: Attributes -> Text showRelationAttributes attrs = "{" <> T.concat (L.intersperse ", " $ L.map showAttribute attrsL) <> "}" @@ -153,3 +157,11 @@ case U.fromString uuidStr of Nothing -> fail "Invalid uuid string" Just uuid -> return uuid + +utcTimeP :: Parser UTCTime +utcTimeP = do + timeStr <- quotedString + case parseTimeM True defaultTimeLocale "%Y-%m-%d %H:%M:%S" (T.unpack timeStr) of + Nothing -> fail "invalid datetime input, use \"YYYY-MM-DD HH:MM:SS\"" + Just stamp -> pure stamp + diff --git a/src/bin/TutorialD/Interpreter/DataTypes/DateTime.hs b/src/bin/TutorialD/Interpreter/DataTypes/DateTime.hs deleted file mode 100644 --- a/src/bin/TutorialD/Interpreter/DataTypes/DateTime.hs +++ /dev/null @@ -1,22 +0,0 @@ -module TutorialD.Interpreter.DataTypes.DateTime where -import Text.Parsec -import ProjectM36.Base -import Text.Parsec.String -import TutorialD.Interpreter.Base -import Data.Time.Clock -import Data.Time.Format - -dateTimeAtomP :: Parser Atom -dateTimeAtomP = do - dateTime' <- try $ do - dateTime <- dateTimeStringP - reserved "::datetime" - return dateTime - return $ Atom dateTime' - -dateTimeStringP :: Parser UTCTime -dateTimeStringP = do - dateTimeString <- quotedString - case parseTimeM False defaultTimeLocale "%Y-%m-%d %H:%M:%S" dateTimeString of - Just utctime -> return $ (utctime :: UTCTime) - Nothing -> fail $ "Failed to parse datetime from " ++ dateTimeString diff --git a/src/bin/TutorialD/Interpreter/DataTypes/Interval.hs b/src/bin/TutorialD/Interpreter/DataTypes/Interval.hs deleted file mode 100644 --- a/src/bin/TutorialD/Interpreter/DataTypes/Interval.hs +++ /dev/null @@ -1,35 +0,0 @@ -module TutorialD.Interpreter.DataTypes.Interval where -import Text.Parsec -import Text.Parsec.String -import ProjectM36.Base hiding (Finite) -import ProjectM36.DataTypes.Interval () -import TutorialD.Interpreter.Base -import TutorialD.Interpreter.DataTypes.DateTime -import Data.Interval -import Data.Time.Clock - -intervalP :: (Ord a) => Parser (Extended a) -> Parser (Interval a) -intervalP unitP = do - lBoundClosed <- string "(" *> return False <|> - string "[" *> return True - lBound <- unitP - reservedOp "," - uBound <- unitP - - uBoundClosed <- string ")" *> return False <|> - string "]" *> return True - - return $ interval (lBound, lBoundClosed) (uBound, uBoundClosed) - -intervalDateTimeUnitP :: Parser (Extended UTCTime) -intervalDateTimeUnitP = Finite <$> dateTimeStringP <|> - (reserved "inf" *> return PosInf) <|> - (reserved "-inf" *> return NegInf) - -intervalDateTimeAtomP :: Parser Atom -intervalDateTimeAtomP = do - reserved "interval_datetime(" - intv <- intervalP intervalDateTimeUnitP - reserved ")" - return $ Atom intv - diff --git a/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs b/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs --- a/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs +++ b/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs @@ -91,7 +91,7 @@ reservedOp "update" relVarName <- identifier predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaceConsumer) - attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignmentP comma) + attributeAssignments <- M.fromList <$> parens (sepBy attributeAssignmentP comma) return $ Update relVarName attributeAssignments predicate data IncDepOp = SubsetOp | EqualityOp @@ -146,7 +146,7 @@ attrName <- identifier reservedOp ":=" atomExpr <- atomExprP - pure $ (attrName, atomExpr) + pure (attrName, atomExpr) addNotificationP :: Parser DatabaseContextExpr addNotificationP = do diff --git a/src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs b/src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs --- a/src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs +++ b/src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs @@ -6,26 +6,25 @@ import TutorialD.Interpreter.Types import Text.Megaparsec import Text.Megaparsec.Text +import Data.Text addAtomFunctionExprP :: Parser DatabaseContextIOExpr -addAtomFunctionExprP = do - reserved "addatomfunction" +addAtomFunctionExprP = dbioexprP "addatomfunction" AddAtomFunction + +addDatabaseContextFunctionExprP :: Parser DatabaseContextIOExpr +addDatabaseContextFunctionExprP = dbioexprP "adddatabasecontextfunction" AddDatabaseContextFunction + +dbioexprP :: String -> (Text -> [TypeConstructor] -> Text -> DatabaseContextIOExpr) -> Parser DatabaseContextIOExpr +dbioexprP res adt = do + reserved res funcName <- quotedString funcType <- atomTypeSignatureP funcScript <- quotedString - pure $ AddAtomFunction funcName funcType funcScript + pure $ adt funcName funcType funcScript atomTypeSignatureP :: Parser [TypeConstructor] atomTypeSignatureP = sepBy typeConstructorP arrow -addDatabaseContextFunctionExprP :: Parser DatabaseContextIOExpr -addDatabaseContextFunctionExprP = do - reserved "adddatabasecontextfunction" - funcName <- quotedString - funcType <- atomTypeSignatureP - funcScript <- quotedString - pure $ AddDatabaseContextFunction funcName funcType funcScript - dbContextIOExprP :: Parser DatabaseContextIOExpr dbContextIOExprP = addAtomFunctionExprP <|> addDatabaseContextFunctionExprP diff --git a/src/bin/TutorialD/Interpreter/Export/Base.hs b/src/bin/TutorialD/Interpreter/Export/Base.hs --- a/src/bin/TutorialD/Interpreter/Export/Base.hs +++ b/src/bin/TutorialD/Interpreter/Export/Base.hs @@ -9,5 +9,5 @@ show (RelVarDataExportOperator expr path _) = "RelVarDataExportOperator " <> show expr <> " " <> path evalRelVarDataExportOperator :: RelVarDataExportOperator -> Relation -> IO (Maybe RelationalError) -evalRelVarDataExportOperator op@(RelVarDataExportOperator _ _ exportFunc) rel = exportFunc op rel +evalRelVarDataExportOperator op@(RelVarDataExportOperator _ _ exportFunc) = exportFunc op diff --git a/src/bin/TutorialD/Interpreter/Export/CSV.hs b/src/bin/TutorialD/Interpreter/Export/CSV.hs --- a/src/bin/TutorialD/Interpreter/Export/CSV.hs +++ b/src/bin/TutorialD/Interpreter/Export/CSV.hs @@ -18,7 +18,7 @@ return $ RelVarDataExportOperator exportExpr (T.unpack path) exportRelationCSV exportRelationCSV :: RelVarDataExportOperator -> Relation -> IO (Maybe RelationalError) -exportRelationCSV (RelVarDataExportOperator _ pathOut _) rel = do +exportRelationCSV (RelVarDataExportOperator _ pathOut _) rel = case relationAsCSV rel of Left err -> return $ Just err Right csvData -> do diff --git a/src/bin/TutorialD/Interpreter/Import/TutorialD.hs b/src/bin/TutorialD/Interpreter/Import/TutorialD.hs --- a/src/bin/TutorialD/Interpreter/Import/TutorialD.hs +++ b/src/bin/TutorialD/Interpreter/Import/TutorialD.hs @@ -17,7 +17,7 @@ tutdData <- try (TIO.readFile pathIn) :: IO (Either IOError T.Text) case tutdData of Left err -> return $ Left (ImportError $ T.pack (show err)) - Right tutdData' -> do + Right tutdData' -> case parse multipleDatabaseContextExprP "import" tutdData' of --parseErrorPretty is new in megaparsec 5 Left err -> pure (Left (PM36E.ParseError (T.pack (show err)))) diff --git a/src/bin/TutorialD/Interpreter/InformationOperator.hs b/src/bin/TutorialD/Interpreter/InformationOperator.hs --- a/src/bin/TutorialD/Interpreter/InformationOperator.hs +++ b/src/bin/TutorialD/Interpreter/InformationOperator.hs @@ -21,7 +21,7 @@ getVersionP = reserved ":version" >> pure GetVersionOperator evalInformationOperator :: InformationOperator -> Either Text Text -evalInformationOperator GetVersionOperator = Right ("tutd " `append` PROJECTM36_VERSION) +evalInformationOperator GetVersionOperator = Right ("tutd " `append` VERSION_project_m36) -- display generic help evalInformationOperator HelpOperator = Right $ intercalate "\n" help where diff --git a/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs b/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs --- a/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs +++ b/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs @@ -98,7 +98,7 @@ Left err -> DisplayErrorResult $ T.pack (show err) Right rel -> DisplayIOResult $ do err <- plotRelation rel - when (isJust err) $ putStrLn (show err) + when (isJust err) $ print err evalRODatabaseContextOp sessionId conn (ShowConstraint name) = do eIncDeps <- C.inclusionDependencies sessionId conn @@ -131,7 +131,7 @@ Left err -> pure $ DisplayErrorResult (T.pack (show err)) Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel)) -evalRODatabaseContextOp _ _ (Quit) = pure QuitResult +evalRODatabaseContextOp _ _ Quit = pure QuitResult interpretRODatabaseContextOp :: C.SessionId -> C.Connection -> T.Text -> IO TutorialDOperatorResult interpretRODatabaseContextOp sessionId conn tutdstring = case parse roDatabaseContextOperatorP "" tutdstring of diff --git a/src/bin/TutorialD/Interpreter/RelationalExpr.hs b/src/bin/TutorialD/Interpreter/RelationalExpr.hs --- a/src/bin/TutorialD/Interpreter/RelationalExpr.hs +++ b/src/bin/TutorialD/Interpreter/RelationalExpr.hs @@ -9,7 +9,6 @@ import qualified Data.Set as S import qualified Data.Map as M import Data.List (sort) -import Control.Applicative (liftA) import ProjectM36.MiscUtils class RelationalMarkerExpr a where @@ -29,7 +28,7 @@ makeRelationP :: RelationalMarkerExpr a => Parser (RelationalExprBase a) makeRelationP = do reserved "relation" - attrExprs <- try (liftA Just makeAttributeExprsP) <|> pure Nothing + attrExprs <- try (fmap Just makeAttributeExprsP) <|> pure Nothing tupleExprs <- braces (sepBy tupleExprP comma) <|> pure [] pure $ MakeRelationFromExprs attrExprs tupleExprs @@ -54,7 +53,7 @@ attrAssocs <- braces (sepBy tupleAtomExprP comma) --detect duplicate attribute names let dupAttrNames = dupes (sort (map fst attrAssocs)) - if length dupAttrNames /= 0 then + if not (null dupAttrNames) then fail ("Attribute names duplicated: " ++ show dupAttrNames) else pure (TupleExpr (M.fromList attrAssocs)) @@ -63,7 +62,7 @@ tupleAtomExprP = do attributeName <- identifier atomExpr <- atomExprP - pure $ (attributeName, atomExpr) + pure (attributeName, atomExpr) projectP :: Parser (RelationalExprBase a -> RelationalExprBase a) projectP = do @@ -75,7 +74,7 @@ oldAttr <- identifier reservedOp "as" newAttr <- identifier - pure $ (oldAttr, newAttr) + pure (oldAttr, newAttr) renameP :: Parser (RelationalExprBase a -> RelationalExprBase a) renameP = do @@ -83,7 +82,7 @@ renameList <- braces (sepBy renameClauseP comma) case renameList of [] -> pure (Restrict TruePredicate) --no-op when rename list is empty - renames -> do + renames -> pure $ \expr -> foldl (\acc (oldAttr, newAttr) -> Rename oldAttr newAttr acc) expr renames whereClauseP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a) @@ -94,7 +93,7 @@ attrs <- braces attributeListP reservedOp "as" newAttrName <- identifier - return $ (attrs, newAttrName) + pure (attrs, newAttrName) groupP :: Parser (RelationalExprBase a -> RelationalExprBase a) groupP = do @@ -148,7 +147,7 @@ [InfixL (reservedOp "and" >> return AndPredicate)], [InfixL (reservedOp "or" >> return OrPredicate)] ] - predicateTerm = parens restrictionPredicateP + predicateTerm = try (parens restrictionPredicateP) <|> try restrictionAtomExprP <|> try restrictionAttributeEqualityP <|> try relationalBooleanExprP @@ -156,7 +155,8 @@ relationalBooleanExprP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a) relationalBooleanExprP = do - relexpr <- relExprP + relexpr <- parens relExprP <|> relTerm + --we can't actually detect if the type is relational boolean, so we just pass it to the next phase return $ RelationalExprPredicate relexpr restrictionAttributeEqualityP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a) @@ -229,10 +229,10 @@ relationalAtomExprP = RelationAtomExpr <$> relExprP stringAtomP :: Parser Atom -stringAtomP = liftA TextAtom quotedString +stringAtomP = TextAtom <$> quotedString doubleAtomP :: Parser Atom -doubleAtomP = DoubleAtom <$> (try float) +doubleAtomP = DoubleAtom <$> try float intAtomP :: Parser Atom intAtomP = do diff --git a/src/bin/TutorialD/Interpreter/SchemaOperator.hs b/src/bin/TutorialD/Interpreter/SchemaOperator.hs --- a/src/bin/TutorialD/Interpreter/SchemaOperator.hs +++ b/src/bin/TutorialD/Interpreter/SchemaOperator.hs @@ -74,7 +74,7 @@ isoUnionInRelVarsP :: Parser (RelVarName, RelVarName) isoUnionInRelVarsP = (,) <$> qrelVarP <*> qrelVarP -evalSchemaOperator :: SessionId -> Connection -> SchemaOperator -> IO (Maybe RelationalError) +evalSchemaOperator :: SessionId -> Connection -> SchemaOperator -> IO (Either RelationalError ()) evalSchemaOperator sessionId conn (ModifySchemaExpr expr) = executeSchemaExpr sessionId conn expr evalSchemaOperator sessionId conn (SetCurrentSchema sname) = setCurrentSchemaName sessionId conn sname diff --git a/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs b/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs --- a/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs +++ b/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs @@ -16,8 +16,8 @@ instance RelationalMarkerExpr TransactionIdLookup where parseMarkerP = string "@" *> transactionIdLookupP -data TransGraphRelationalOperator = ShowTransGraphRelation TransGraphRelationalExpr - deriving Show +newtype TransGraphRelationalOperator = ShowTransGraphRelation TransGraphRelationalExpr + deriving Show transactionIdLookupP :: Parser TransactionIdLookup transactionIdLookupP = (TransactionIdLookup <$> uuidP) <|> @@ -25,7 +25,8 @@ transactionIdHeadBacktrackP :: Parser TransactionIdHeadBacktrack transactionIdHeadBacktrackP = (string "~" *> (TransactionIdHeadParentBacktrack <$> backtrackP)) <|> - (string "^" *> (TransactionIdHeadBranchBacktrack <$> backtrackP)) + (string "^" *> (TransactionIdHeadBranchBacktrack <$> backtrackP)) <|> + (string "@" *> (TransactionStampHeadBacktrack <$> utcTimeP)) backtrackP :: Parser Int backtrackP = do diff --git a/src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs b/src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs --- a/src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs +++ b/src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs @@ -3,11 +3,22 @@ import TutorialD.Interpreter.Base import Text.Megaparsec.Text import Text.Megaparsec -import ProjectM36.TransactionGraph +import ProjectM36.TransactionGraph hiding (autoMergeToHead) import ProjectM36.Client import ProjectM36.Error import ProjectM36.Base +data ConvenienceTransactionGraphOperator = AutoMergeToHead MergeStrategy HeadName + deriving (Show) + +convenienceTransactionGraphOpP :: Parser ConvenienceTransactionGraphOperator +convenienceTransactionGraphOpP = autoMergeToHeadP + +autoMergeToHeadP :: Parser ConvenienceTransactionGraphOperator +autoMergeToHeadP = do + reserved ":automergetohead" + AutoMergeToHead <$> mergeTransactionStrategyP <*> identifier + jumpToHeadP :: Parser TransactionGraphOperator jumpToHeadP = do reservedOp ":jumphead" @@ -19,6 +30,11 @@ reservedOp ":jump" uuid <- uuidP return $ JumpToTransaction uuid + +walkBackToTimeP :: Parser TransactionGraphOperator +walkBackToTimeP = do + reservedOp ":walkbacktotime" + WalkBackToTime <$> utcTimeP branchTransactionP :: Parser TransactionGraphOperator branchTransactionP = do @@ -34,17 +50,17 @@ commitTransactionP :: Parser TransactionGraphOperator commitTransactionP = do reservedOp ":commit" - return $ Commit ForbidEmptyCommitOption + pure Commit rollbackTransactionP :: Parser TransactionGraphOperator rollbackTransactionP = do reservedOp ":rollback" - return $ Rollback + return Rollback showGraphP :: Parser ROTransactionGraphOperator showGraphP = do reservedOp ":showgraph" - return $ ShowGraph + return ShowGraph mergeTransactionStrategyP :: Parser MergeStrategy mergeTransactionStrategyP = (reserved "union" *> pure UnionMergeStrategy) <|> @@ -66,9 +82,10 @@ pure (MergeTransactions strategy headA headB) transactionGraphOpP :: Parser TransactionGraphOperator -transactionGraphOpP = do +transactionGraphOpP = jumpToHeadP <|> jumpToTransactionP + <|> walkBackToTimeP <|> branchTransactionP <|> deleteBranchP <|> commitTransactionP @@ -94,3 +111,6 @@ evalROGraphOp :: SessionId -> Connection -> ROTransactionGraphOperator -> IO (Either RelationalError Relation) evalROGraphOp sessionId conn ShowGraph = transactionGraphAsRelation sessionId conn + +evalConvenienceGraphOp :: SessionId -> Connection -> ConvenienceTransactionGraphOperator -> IO (Either RelationalError ()) +evalConvenienceGraphOp sessionId conn (AutoMergeToHead strat head') = autoMergeToHead sessionId conn strat head' diff --git a/src/bin/TutorialD/tutd.hs b/src/bin/TutorialD/tutd.hs --- a/src/bin/TutorialD/tutd.hs +++ b/src/bin/TutorialD/tutd.hs @@ -71,12 +71,12 @@ errDie :: String -> IO () errDie err = hPutStrLn stderr err >> exitFailure -#ifndef PROJECTM36_VERSION -#error PROJECTM36_VERSION is not defined +#ifndef VERSION_project_m36 +#error VERSION_project_m36 is not defined #endif printWelcome :: IO () printWelcome = do - putStrLn $ "Project:M36 TutorialD Interpreter " ++ PROJECTM36_VERSION + putStrLn $ "Project:M36 TutorialD Interpreter " ++ VERSION_project_m36 putStrLn "Type \":help\" for more information." putStrLn "A full tutorial is available at:" putStrLn "https://github.com/agentm/project-m36/blob/master/docs/tutd_tutorial.markdown" @@ -87,11 +87,11 @@ let connInfo = connectionInfoForConfig interpreterConfig dbconn <- connectProjectM36 connInfo case dbconn of - Left err -> do + Left err -> errDie ("Failed to create database connection: " ++ show err) Right conn -> do let connHeadName = headNameForConfig interpreterConfig - eSessionId <- createSessionAtHead connHeadName conn + eSessionId <- createSessionAtHead conn connHeadName case eSessionId of Left err -> errDie ("Failed to create database session at \"" ++ show connHeadName ++ "\": " ++ show err) Right sessionId -> do diff --git a/src/bin/benchmark/Relation.hs b/src/bin/benchmark/Relation.hs --- a/src/bin/benchmark/Relation.hs +++ b/src/bin/benchmark/Relation.hs @@ -12,7 +12,7 @@ matrixRelation attributeCount tupleCount = do let attrs = A.attributesFromList $ map (\c-> Attribute (T.pack $ "a" ++ show c) IntAtomType) [0 .. attributeCount-1] tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> IntAtom tupleX)) - tuples = map (\c -> tuple c) [0 .. tupleCount] + tuples = map tuple [0 .. tupleCount] mkRelationDeferVerify attrs (RelationTupleSet tuples) main :: IO () diff --git a/src/bin/benchmark/bigrel.hs b/src/bin/benchmark/bigrel.hs --- a/src/bin/benchmark/bigrel.hs +++ b/src/bin/benchmark/bigrel.hs @@ -26,7 +26,7 @@ dumpcsv :: Relation -> IO () dumpcsv rel = case relationAsCSV rel of - Left err -> hPutStrLn stderr (show err) + Left err -> hPrint stderr err Right bsData -> BS.putStrLn bsData data BigrelArgs = BigrelArgs Int Int Text @@ -52,9 +52,9 @@ --intmapMatrixRun matrixRun :: BigrelArgs -> IO () -matrixRun (BigrelArgs attributeCount tupleCount tutd) = do +matrixRun (BigrelArgs attributeCount tupleCount tutd) = case matrixRelation attributeCount tupleCount of - Left err -> putStrLn (show err) + Left err -> print err Right rel -> if tutd == "" then putStrLn "Done." else do @@ -64,14 +64,14 @@ --plan = interpretRODatabaseContextOp context $ ":showplan " ++ tutd --displayOpResult plan case interpreted of - Right context' -> TIO.putStrLn $ relationAsHTML ((relationVariables context') M.! "x") - Left err -> hPutStrLn stderr (show err) + Right context' -> TIO.putStrLn $ relationAsHTML (relationVariables context' M.! "x") + Left err -> hPrint stderr err intmapMatrixRun :: IO () intmapMatrixRun = do let matrix = intmapMatrixRelation 100 100000 - putStrLn (show matrix) + print matrix --compare IntMap speed and size --this is about 3 times faster (9 minutes) for 10x100000 and uses 800 MB @@ -86,7 +86,7 @@ vectorMatrixRun :: IO () vectorMatrixRun = do let matrix = vectorMatrixRelation 100 100000 - putStrLn (show matrix) + print matrix -- 20 s 90 MBs- a clear win- ideal size is 10 * 100000 * 8 bytes = 80 MB! without IntAtom wrapper --with IntAtom wrapper: 1m12s 90 MB @@ -104,6 +104,6 @@ matrixRelation attributeCount tupleCount = do let attrs = A.attributesFromList $ map (\c-> Attribute (T.pack $ "a" ++ show c) IntAtomType) [0 .. attributeCount-1] tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> IntAtom tupleX)) - tuples = map (\c -> tuple c) [0 .. tupleCount] + tuples = map tuple [0 .. tupleCount] mkRelationDeferVerify attrs (RelationTupleSet tuples) diff --git a/src/lib/ProjectM36/Atom.hs b/src/lib/ProjectM36/Atom.hs --- a/src/lib/ProjectM36/Atom.hs +++ b/src/lib/ProjectM36/Atom.hs @@ -6,6 +6,7 @@ --import Data.Time.Clock --import Data.ByteString (ByteString) import Text.Read +import Data.Monoid relationForAtom :: Atom -> Either RelationalError Relation relationForAtom (RelationAtom rel) = Right rel @@ -29,6 +30,12 @@ atomToText (DateTimeAtom i) = (T.pack . show) i atomToText (ByteStringAtom i) = (T.pack . show) i atomToText (BoolAtom i) = (T.pack . show) i +atomToText (IntervalAtom b e bo be) = beginp <> begin <> "," <> end <> endp + where beginp = if bo then "(" else "[" + begin = atomToText b + end = atomToText e + endp = if be then ")" else "]" + atomToText (RelationAtom i) = (T.pack . show) i atomToText (ConstructedAtom dConsName _ atoms) = dConsName `T.append` T.intercalate " " (map atomToText atoms) diff --git a/src/lib/ProjectM36/AtomFunction.hs b/src/lib/ProjectM36/AtomFunction.hs --- a/src/lib/ProjectM36/AtomFunction.hs +++ b/src/lib/ProjectM36/AtomFunction.hs @@ -42,11 +42,12 @@ --expected atom ret value - used to make funcType lastArg = take 1 (reverse typeIn) case lastArg of - (ADTypeConstructor "Either" - ((ADTypeConstructor "AtomFunctionError" []): - atomRetArg:[])):[] -> do + [ADTypeConstructor "Either" + [ADTypeConstructor "AtomFunctionError" [], + atomRetArg]] -> pure (atomArgs ++ [atomRetArg]) - otherType -> Left (ScriptError (TypeCheckCompilationError "function returning \"Either AtomFunctionError a\"" (show otherType))) + otherType -> + Left (ScriptError (TypeCheckCompilationError "function returning \"Either AtomFunctionError a\"" (show otherType))) isScriptedAtomFunction :: AtomFunction -> Bool isScriptedAtomFunction func = case atomFuncBody func of @@ -59,8 +60,8 @@ -- | Create a 'DatabaseContextIOExpr' which can be used to load a new atom function written in Haskell and loaded at runtime. createScriptedAtomFunction :: AtomFunctionName -> [TypeConstructor] -> TypeConstructor -> AtomFunctionBodyScript -> DatabaseContextIOExpr -createScriptedAtomFunction funcName argsType retType script = AddAtomFunction funcName ( +createScriptedAtomFunction funcName argsType retType = AddAtomFunction funcName ( argsType ++ [ADTypeConstructor "Either" [ ADTypeConstructor "AtomFunctionError" [], - retType]]) script + retType]]) diff --git a/src/lib/ProjectM36/AtomFunctionBody.hs b/src/lib/ProjectM36/AtomFunctionBody.hs --- a/src/lib/ProjectM36/AtomFunctionBody.hs +++ b/src/lib/ProjectM36/AtomFunctionBody.hs @@ -4,4 +4,4 @@ import ProjectM36.Base compiledAtomFunctionBody :: AtomFunctionBodyType -> AtomFunctionBody -compiledAtomFunctionBody func = AtomFunctionBody Nothing func +compiledAtomFunctionBody = AtomFunctionBody Nothing diff --git a/src/lib/ProjectM36/AtomFunctionError.hs b/src/lib/ProjectM36/AtomFunctionError.hs --- a/src/lib/ProjectM36/AtomFunctionError.hs +++ b/src/lib/ProjectM36/AtomFunctionError.hs @@ -3,9 +3,14 @@ import Data.Binary import GHC.Generics import Control.DeepSeq +import Data.Text data AtomFunctionError = AtomFunctionUserError String | AtomFunctionTypeMismatchError | + InvalidIntervalOrdering | + InvalidIntervalBoundaries | + AtomTypeDoesNotSupportOrdering Text | + AtomTypeDoesNotSupportInterval Text | AtomFunctionBytesDecodingError String deriving(Generic, Eq, Show, Binary, NFData) diff --git a/src/lib/ProjectM36/AtomFunctions/Basic.hs b/src/lib/ProjectM36/AtomFunctions/Basic.hs --- a/src/lib/ProjectM36/AtomFunctions/Basic.hs +++ b/src/lib/ProjectM36/AtomFunctions/Basic.hs @@ -4,6 +4,8 @@ import ProjectM36.DataTypes.Day import ProjectM36.DataTypes.Either import ProjectM36.DataTypes.Maybe +import ProjectM36.DataTypes.Interval +import ProjectM36.DataTypes.ByteString import ProjectM36.AtomFunctions.Primitive import ProjectM36.AtomFunction import ProjectM36.DataTypes.List @@ -16,7 +18,9 @@ dateTimeAtomFunctions, eitherAtomFunctions, maybeAtomFunctions, - listAtomFunctions] + listAtomFunctions, + bytestringAtomFunctions, + intervalAtomFunctions] --these special atom functions aren't scripted so they can't be serialized normally. Instead, the body remains in the binary and the serialization/deserialization happens by name only. precompiledAtomFunctions :: AtomFunctions diff --git a/src/lib/ProjectM36/AtomFunctions/Primitive.hs b/src/lib/ProjectM36/AtomFunctions/Primitive.hs --- a/src/lib/ProjectM36/AtomFunctions/Primitive.hs +++ b/src/lib/ProjectM36/AtomFunctions/Primitive.hs @@ -6,15 +6,14 @@ import ProjectM36.AtomFunction import qualified Data.HashSet as HS import qualified Data.Vector as V -import qualified Data.ByteString.Base64 as B64 -import qualified Data.Text.Encoding as TE +import Control.Monad primitiveAtomFunctions :: AtomFunctions primitiveAtomFunctions = HS.fromList [ --match on any relation type AtomFunction { atomFuncName = "add", atomFuncType = [IntAtomType, IntAtomType, IntAtomType], - atomFuncBody = body (\((IntAtom i1):(IntAtom i2):_) -> pure (IntAtom (i1 + i2)))}, + atomFuncBody = body (\(IntAtom i1:IntAtom i2:_) -> pure (IntAtom (i1 + i2)))}, AtomFunction { atomFuncName = "id", atomFuncType = [TypeVariableType "a", TypeVariableType "a"], atomFuncBody = body (\(x:_) -> pure x)}, @@ -23,13 +22,13 @@ atomFuncBody = body (\(RelationAtom rel:_) -> relationSum rel)}, AtomFunction { atomFuncName = "count", atomFuncType = foldAtomFuncType (TypeVariableType "a") IntAtomType, - atomFuncBody = body (\((RelationAtom relIn):_) -> relationCount relIn)}, + atomFuncBody = body (\(RelationAtom relIn:_) -> relationCount relIn)}, AtomFunction { atomFuncName = "max", atomFuncType = foldAtomFuncType IntAtomType IntAtomType, - atomFuncBody = body (\((RelationAtom relIn):_) -> relationMax relIn)}, + atomFuncBody = body (\(RelationAtom relIn:_) -> relationMax relIn)}, AtomFunction { atomFuncName = "min", atomFuncType = foldAtomFuncType IntAtomType IntAtomType, - atomFuncBody = body (\((RelationAtom relIn):_) -> relationMin relIn)}, + atomFuncBody = body (\(RelationAtom relIn:_) -> relationMin relIn)}, AtomFunction { atomFuncName = "lt", atomFuncType = [IntAtomType, IntAtomType, BoolAtomType], atomFuncBody = body $ intAtomFuncLessThan False}, @@ -38,24 +37,19 @@ atomFuncBody = body $ intAtomFuncLessThan True}, AtomFunction { atomFuncName = "gte", atomFuncType = [IntAtomType, IntAtomType, BoolAtomType], - atomFuncBody = body $ \args -> intAtomFuncLessThan False args >>= boolAtomNot}, + atomFuncBody = body $ intAtomFuncLessThan False >=> boolAtomNot}, AtomFunction { atomFuncName = "gt", atomFuncType = [IntAtomType, IntAtomType, BoolAtomType], - atomFuncBody = body $ \args -> intAtomFuncLessThan True args >>= boolAtomNot}, + atomFuncBody = body $ intAtomFuncLessThan True >=> boolAtomNot}, AtomFunction { atomFuncName = "not", atomFuncType = [BoolAtomType, BoolAtomType], - atomFuncBody = body $ \(b:_) -> boolAtomNot b }, - AtomFunction { atomFuncName = "makeByteString", - atomFuncType = [TextAtomType, ByteStringAtomType], - atomFuncBody = body $ \((TextAtom textIn):_) -> case B64.decode (TE.encodeUtf8 textIn) of - Left err -> Left (AtomFunctionBytesDecodingError err) - Right bs -> pure (ByteStringAtom bs) } + atomFuncBody = body $ \(b:_) -> boolAtomNot b } ] where body = AtomFunctionBody Nothing intAtomFuncLessThan :: Bool -> [Atom] -> Either AtomFunctionError Atom -intAtomFuncLessThan equality ((IntAtom i1):(IntAtom i2):_) = pure (BoolAtom (i1 `op` i2)) +intAtomFuncLessThan equality (IntAtom i1:IntAtom i2:_) = pure (BoolAtom (i1 `op` i2)) where op = if equality then (<=) else (<) intAtomFuncLessThan _ _= pure (BoolAtom False) @@ -66,11 +60,11 @@ --used by sum atom function relationSum :: Relation -> Either AtomFunctionError Atom -relationSum relIn = pure (IntAtom (relFold (\tupIn acc -> acc + (newVal tupIn)) 0 relIn)) +relationSum relIn = pure (IntAtom (relFold (\tupIn acc -> acc + newVal tupIn) 0 relIn)) where --extract Int from Atom newVal :: RelationTuple -> Int - newVal tupIn = castInt ((tupleAtoms tupIn) V.! 0) + newVal tupIn = castInt (tupleAtoms tupIn V.! 0) relationCount :: Relation -> Either AtomFunctionError Atom relationCount relIn = pure (IntAtom (relFold (\_ acc -> acc + 1) (0::Int) relIn)) @@ -78,12 +72,12 @@ relationMax :: Relation -> Either AtomFunctionError Atom relationMax relIn = pure (IntAtom (relFold (\tupIn acc -> max acc (newVal tupIn)) minBound relIn)) where - newVal tupIn = castInt ((tupleAtoms tupIn) V.! 0) + newVal tupIn = castInt (tupleAtoms tupIn V.! 0) relationMin :: Relation -> Either AtomFunctionError Atom relationMin relIn = pure (IntAtom (relFold (\tupIn acc -> min acc (newVal tupIn)) maxBound relIn)) where - newVal tupIn = castInt ((tupleAtoms tupIn) V.! 0) + newVal tupIn = castInt (tupleAtoms tupIn V.! 0) castInt :: Atom -> Int castInt (IntAtom i) = i diff --git a/src/lib/ProjectM36/AtomType.hs b/src/lib/ProjectM36/AtomType.hs --- a/src/lib/ProjectM36/AtomType.hs +++ b/src/lib/ProjectM36/AtomType.hs @@ -17,7 +17,7 @@ import qualified Data.Text as T findDataConstructor :: DataConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, DataConstructorDef) -findDataConstructor dName tConsList = foldr tConsFolder Nothing tConsList +findDataConstructor dName = foldr tConsFolder Nothing where tConsFolder (tCons, dConsList) accum = if isJust accum then accum @@ -34,7 +34,7 @@ -- Used in typeFromAtomExpr to validate argument types. atomTypeForDataConstructorName :: DataConstructorName -> [AtomType] -> TypeConstructorMapping -> Either RelationalError AtomType -- search for the data constructor and resolve the types' names -atomTypeForDataConstructorName dConsName atomTypesIn tConsList = do +atomTypeForDataConstructorName dConsName atomTypesIn tConsList = case findDataConstructor dConsName tConsList of Nothing -> Left (NoSuchDataConstructorError dConsName) Just (tCons, dCons) -> do @@ -61,7 +61,7 @@ -- | Used to determine if the atom arguments can be used with the data constructor. -- | This is the entry point for type-checking from RelationalExpression.hs. atomTypeForDataConstructor :: TypeConstructorMapping -> DataConstructorName -> [AtomType] -> Either RelationalError AtomType -atomTypeForDataConstructor tConss dConsName atomArgTypes = do +atomTypeForDataConstructor tConss dConsName atomArgTypes = --lookup the data constructor case findDataConstructor dConsName tConss of Nothing -> Left (NoSuchDataConstructorError dConsName) @@ -135,13 +135,13 @@ atomTypeForTypeConstructor tCons tConss = case findTypeConstructor (TC.name tCons) tConss of Nothing -> Left (NoSuchTypeConstructorError (TC.name tCons)) Just (tConsDef, _) -> do - tConsArgTypes <- mapM ((flip atomTypeForTypeConstructor) tConss) (TC.arguments tCons) + tConsArgTypes <- mapM (`atomTypeForTypeConstructor` tConss) (TC.arguments tCons) let pVarNames = TCD.typeVars tConsDef tConsArgs = M.fromList (zip pVarNames tConsArgTypes) Right (ConstructedAtomType (TC.name tCons) tConsArgs) findTypeConstructor :: TypeConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, [DataConstructorDef]) -findTypeConstructor name tConsList = foldr tConsFolder Nothing tConsList +findTypeConstructor name = foldr tConsFolder Nothing where tConsFolder (tCons, dConsList) accum = if TCD.name tCons == name then Just (tCons, dConsList) @@ -170,7 +170,7 @@ Nothing -> Left (TypeConstructorTypeVarMissing key) Just val -> Right val -} - let resolveTypePair resKey resType = do + let resolveTypePair resKey resType = -- if the key is missing in the unresolved type map, then fill it in with the value from the resolved map case M.lookup resKey unresolvedTypeMap of Just unresType -> case unresType of @@ -179,7 +179,7 @@ resSubType <- resolveAtomType resType subType pure (resKey, resSubType) otherType -> pure (resKey, otherType) - Nothing -> do + Nothing -> pure (resKey, resType) --swipe the missing type var from the expected map tVarList <- mapM (uncurry resolveTypePair) (M.toList resolvedTypeMap) pure (M.fromList tVarList) @@ -195,12 +195,12 @@ -- Example: "Nothing" does not specify the the argument in "Maybe a", so allow delayed resolution in the tuple before it is added to the relation. Note that this resolution could cause a type error. Hardly a Hindley-Milner system. resolveTypesInTuple :: Attributes -> RelationTuple -> Either RelationalError RelationTuple resolveTypesInTuple resolvedAttrs (RelationTuple _ tupAtoms) = do - newAtoms <- mapM (\(atom, resolvedType) -> resolveTypeInAtom resolvedType atom) (zip (V.toList tupAtoms) $ (map A.atomType (V.toList resolvedAttrs))) + newAtoms <- mapM (\(atom, resolvedType) -> resolveTypeInAtom resolvedType atom) (zip (V.toList tupAtoms) $ map A.atomType (V.toList resolvedAttrs)) Right (RelationTuple resolvedAttrs (V.fromList newAtoms)) -- | Validate that the type is provided with complete type variables for type constructors. validateAtomType :: AtomType -> TypeConstructorMapping -> Either RelationalError () -validateAtomType typ@(ConstructedAtomType tConsName tVarMap) tConss = do +validateAtomType typ@(ConstructedAtomType tConsName tVarMap) tConss = case findTypeConstructor tConsName tConss of Nothing -> Left (TypeConstructorAtomTypeMismatch tConsName typ) Just (tConsDef, _) -> case tConsDef of @@ -221,13 +221,11 @@ atomTypeVerify :: AtomType -> AtomType -> Either RelationalError AtomType atomTypeVerify (TypeVariableType _) x = Right x atomTypeVerify x (TypeVariableType _) = Right x -atomTypeVerify x@(ConstructedAtomType tConsNameA tVarMapA) (ConstructedAtomType tConsNameB tVarMapB) = - if tConsNameA /= tConsNameB then - Left (TypeConstructorNameMismatch tConsNameA tConsNameB) - else if not (typeVarMapsVerify tVarMapA tVarMapB) then - Left (TypeConstructorTypeVarsTypesMismatch tConsNameA tVarMapA tVarMapB) - else - Right x +atomTypeVerify x@(ConstructedAtomType tConsNameA tVarMapA) (ConstructedAtomType tConsNameB tVarMapB) + | tConsNameA /= tConsNameB = Left (TypeConstructorNameMismatch tConsNameA tConsNameB) + | not (typeVarMapsVerify tVarMapA tVarMapB) = Left (TypeConstructorTypeVarsTypesMismatch tConsNameA tVarMapA tVarMapB) + | otherwise = Right x + atomTypeVerify x@(RelationAtomType attrs1) y@(RelationAtomType attrs2) = do _ <- mapM (\(attr1,attr2) -> let name1 = A.attributeName attr1 name2 = A.attributeName attr2 in @@ -236,6 +234,7 @@ else atomTypeVerify (A.atomType attr1) (A.atomType attr2)) $ V.toList (V.zip attrs1 attrs2) return x +atomTypeVerify (IntervalAtomType typA) (IntervalAtomType typB) = atomTypeVerify typA typB atomTypeVerify x y = if x == y then Right x else @@ -252,6 +251,7 @@ showTypeVars (tyVarName, aType) = " (" `T.append` tyVarName `T.append` "::" `T.append` prettyAtomType aType `T.append` ")" -- it would be nice to have the original ordering, but we don't have access to the type constructor here- maybe the typevarmap should be also positional (ordered map?) prettyAtomType (TypeVariableType x) = "?TypeVariableType " <> x <> "?" +prettyAtomType (IntervalAtomType tv) = "Interval (" <> prettyAtomType tv <> ")" prettyAtomType aType = T.take (T.length fullName - T.length "AtomType") fullName where fullName = (T.pack . show) aType @@ -260,7 +260,7 @@ resolveTypeVariables :: [AtomType] -> [AtomType] -> Either RelationalError TypeVarMap resolveTypeVariables expectedArgTypes actualArgTypes = do - let tvmaps = map (uncurry resolveTypeVariable) (zip expectedArgTypes actualArgTypes) + let tvmaps = zipWith resolveTypeVariable expectedArgTypes actualArgTypes --if there are any new keys which don't have equal values then we have a conflict! foldM (\acc tvmap -> do let inter = M.intersectionWithKey (\tvName vala valb -> @@ -275,6 +275,7 @@ resolveTypeVariable :: AtomType -> AtomType -> TypeVarMap resolveTypeVariable (TypeVariableType tv) typ = M.singleton tv typ +resolveTypeVariable (IntervalAtomType ityp) typ = resolveTypeVariable ityp typ resolveTypeVariable (ConstructedAtomType _ _) (ConstructedAtomType _ actualTvMap) = actualTvMap resolveTypeVariable _ _ = M.empty @@ -285,6 +286,7 @@ pure (ConstructedAtomType tCons (M.intersection tvMap retMap)) else Left (AtomFunctionTypeVariableResolutionError funcName (fst (head (M.toList diff)))) +resolveFunctionReturnValue funcName tvMap (IntervalAtomType tv) = IntervalAtomType <$> resolveFunctionReturnValue funcName tvMap tv resolveFunctionReturnValue funcName tvMap (TypeVariableType tvName) = case M.lookup tvName tvMap of Nothing -> Left (AtomFunctionTypeVariableResolutionError funcName tvName) Just typ -> pure typ diff --git a/src/lib/ProjectM36/Atomable.hs b/src/lib/ProjectM36/Atomable.hs --- a/src/lib/ProjectM36/Atomable.hs +++ b/src/lib/ProjectM36/Atomable.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DefaultSignatures, TypeFamilies, TypeOperators, PolyKinds, FlexibleInstances, ScopedTypeVariables, FlexibleContexts, DeriveGeneric, DeriveAnyClass #-} +{-# LANGUAGE DefaultSignatures, TypeFamilies, TypeOperators, PolyKinds, FlexibleInstances, ScopedTypeVariables, FlexibleContexts #-} module ProjectM36.Atomable where --http://stackoverflow.com/questions/13448361/type-families-with-ghc-generics-or-data-data --instances to marshal Haskell ADTs to ConstructedAtoms and back @@ -15,6 +15,7 @@ import Data.Time.Calendar import Data.ByteString (ByteString) import Data.Time.Clock +import Data.Maybe --also add haskell scripting atomable support --rename this module to Atomable along with test @@ -49,66 +50,66 @@ toAtomType v = toAtomTypeG (from v) -- | Creates DatabaseContextExpr necessary to load the type constructor and data constructor into the database. - toDatabaseContextExpr :: a -> DatabaseContextExpr - default toDatabaseContextExpr :: (Generic a, AtomableG (Rep a)) => a -> DatabaseContextExpr - toDatabaseContextExpr v = toDatabaseContextExprG (from v) (toAtomType v) + toAddTypeExpr :: a -> DatabaseContextExpr + default toAddTypeExpr :: (Generic a, AtomableG (Rep a)) => a -> DatabaseContextExpr + toAddTypeExpr v = toAddTypeExprG (from v) (toAtomType v) instance Atomable Int where - toAtom i = IntAtom i + toAtom = IntAtom fromAtom (IntAtom i) = i fromAtom e = error ("improper fromAtom" ++ show e) toAtomType _ = IntAtomType - toDatabaseContextExpr _ = NoOperation + toAddTypeExpr _ = NoOperation instance Atomable Double where - toAtom d = DoubleAtom d + toAtom = DoubleAtom fromAtom (DoubleAtom d) = d fromAtom _ = error "improper fromAtom" toAtomType _ = DoubleAtomType - toDatabaseContextExpr _ = NoOperation + toAddTypeExpr _ = NoOperation instance Atomable T.Text where - toAtom t = TextAtom t + toAtom = TextAtom fromAtom (TextAtom t) = t fromAtom _ = error "improper fromAtom" toAtomType _ = TextAtomType - toDatabaseContextExpr _ = NoOperation + toAddTypeExpr _ = NoOperation instance Atomable Day where - toAtom d = DayAtom d + toAtom = DayAtom fromAtom (DayAtom d) = d fromAtom _ = error "improper fromAtom" toAtomType _ = DayAtomType - toDatabaseContextExpr _ = NoOperation + toAddTypeExpr _ = NoOperation instance Atomable UTCTime where - toAtom t = DateTimeAtom t + toAtom = DateTimeAtom fromAtom (DateTimeAtom t) = t fromAtom _ = error "improper fromAtom" toAtomType _ = DateTimeAtomType - toDatabaseContextExpr _ = NoOperation + toAddTypeExpr _ = NoOperation instance Atomable ByteString where toAtom = ByteStringAtom fromAtom (ByteStringAtom b) = b fromAtom _ = error "improper fromAtom" toAtomType _ = ByteStringAtomType - toDatabaseContextExpr _ = NoOperation + toAddTypeExpr _ = NoOperation instance Atomable Bool where toAtom = BoolAtom fromAtom (BoolAtom b) = b fromAtom _ = error "improper fromAtom" toAtomType _ = BoolAtomType - toDatabaseContextExpr _ = NoOperation - + toAddTypeExpr _ = NoOperation + instance Atomable Relation where toAtom = RelationAtom fromAtom (RelationAtom r) = r fromAtom _ = error "improper fromAtom" --warning: cannot be used with undefined "Relation" toAtomType rel = RelationAtomType (attributes rel) - toDatabaseContextExpr _ = NoOperation + toAddTypeExpr _ = NoOperation --convert to ADT list instance Atomable a => Atomable [a] where @@ -120,7 +121,7 @@ fromAtom _ = error "improper fromAtom [a]" toAtomType _ = ConstructedAtomType "List" (M.singleton "a" (toAtomType (undefined :: a))) - toDatabaseContextExpr _ = NoOperation + toAddTypeExpr _ = NoOperation -- Generics class AtomableG g where @@ -129,23 +130,23 @@ fromAtomG :: Atom -> [Atom] -> Maybe (g a) toAtomTypeG :: g a -> AtomType --overall ConstructedAtomType toAtomsG :: g a -> [Atom] - toDatabaseContextExprG :: g a -> AtomType -> DatabaseContextExpr + toAddTypeExprG :: g a -> AtomType -> DatabaseContextExpr getConstructorsG :: g a -> [DataConstructorDef] getConstructorArgsG :: g a -> [DataConstructorDefArg] --data type metadata instance (Datatype c, AtomableG a) => AtomableG (M1 D c a) where - toAtomG (M1 v) t = toAtomG v t + toAtomG (M1 v) = toAtomG v fromAtomG atom args = M1 <$> fromAtomG atom args toAtomsG = undefined toAtomTypeG _ = ConstructedAtomType (T.pack typeName) M.empty -- generics don't allow us to get the type constructor variables- alternatives? where typeName = datatypeName (undefined :: M1 D c a x) - toDatabaseContextExprG (M1 v) (ConstructedAtomType tcName _) = AddTypeConstructor tcDef dataConstructors + toAddTypeExprG (M1 v) (ConstructedAtomType tcName _) = AddTypeConstructor tcDef dataConstructors where tcDef = ADTypeConstructorDef tcName [] dataConstructors = getConstructorsG v - toDatabaseContextExprG _ _ = NoOperation + toAddTypeExprG _ _ = NoOperation getConstructorsG (M1 v) = getConstructorsG v getConstructorArgsG = undefined @@ -165,7 +166,7 @@ fromAtomG _ _ = error "unsupported generic traversal" toAtomsG = undefined toAtomTypeG = undefined - toDatabaseContextExprG = undefined + toAddTypeExprG = undefined getConstructorsG (M1 v) = [DataConstructorDef (T.pack dName) dArgs] where dName = conName (undefined :: M1 C c a x) @@ -178,7 +179,7 @@ fromAtomG atom args = M1 <$> fromAtomG atom args toAtomsG (M1 v) = toAtomsG v toAtomTypeG (M1 v) = toAtomTypeG v - toDatabaseContextExprG _ _ = undefined + toAddTypeExprG _ _ = undefined getConstructorsG = undefined getConstructorArgsG (M1 v) = getConstructorArgsG v @@ -190,36 +191,34 @@ headatom [] = error "no more atoms for constructor!" toAtomsG (K1 v) = [toAtom v] toAtomTypeG _ = toAtomType (undefined :: a) - toDatabaseContextExprG _ _ = undefined + toAddTypeExprG _ _ = undefined getConstructorsG = undefined getConstructorArgsG (K1 v) = [DataConstructorDefTypeConstructorArg tCons] where tCons = PrimitiveTypeConstructor primitiveATypeName primitiveAType primitiveAType = toAtomType v - primitiveATypeName = case foldr (\((PrimitiveTypeConstructorDef name typ), _) _ -> if typ == primitiveAType then Just name else Nothing) Nothing primitiveTypeConstructorMapping of - Just x -> x - Nothing -> error ("primitive type missing: " ++ show primitiveAType) + primitiveATypeName = fromMaybe (error ("primitive type missing: " ++ show primitiveAType)) (foldr (\(PrimitiveTypeConstructorDef name typ, _) _ -> if typ == primitiveAType then Just name else Nothing) Nothing primitiveTypeConstructorMapping) instance AtomableG U1 where toAtomG = undefined fromAtomG _ _ = pure U1 toAtomsG _ = [] toAtomTypeG = undefined - toDatabaseContextExprG = undefined + toAddTypeExprG = undefined getConstructorsG = undefined getConstructorArgsG _ = [] -- product types instance (AtomableG a, AtomableG b) => AtomableG (a :*: b) where toAtomG = undefined - fromAtomG atom args = (:*:) <$> (fromAtomG atom [headatom args]) <*> (fromAtomG atom (tailatoms args)) + fromAtomG atom args = (:*:) <$> fromAtomG atom [headatom args] <*> fromAtomG atom (tailatoms args) where headatom (x:_) = x headatom [] = error "no more atoms in head for product!" tailatoms (_:xs) = xs tailatoms [] = error "no more atoms in tail for product!" toAtomTypeG = undefined toAtomsG (x :*: y) = toAtomsG x ++ toAtomsG y - toDatabaseContextExprG _ _ = undefined + toAddTypeExprG _ _ = undefined getConstructorsG = undefined getConstructorArgsG (x :*: y) = getConstructorArgsG x ++ getConstructorArgsG y @@ -231,7 +230,7 @@ toAtomTypeG = undefined toAtomsG (L1 x) = toAtomsG x toAtomsG (R1 x) = toAtomsG x - toDatabaseContextExprG _ _ = undefined + toAddTypeExprG _ _ = undefined getConstructorsG _ = getConstructorsG (undefined :: a x) ++ getConstructorsG (undefined :: b x) getConstructorArgsG = undefined diff --git a/src/lib/ProjectM36/Attribute.hs b/src/lib/ProjectM36/Attribute.hs --- a/src/lib/ProjectM36/Attribute.hs +++ b/src/lib/ProjectM36/Attribute.hs @@ -27,7 +27,7 @@ atomType (Attribute _ atype) = atype atomTypes :: Attributes -> V.Vector AtomType -atomTypes attrs = V.map atomType attrs +atomTypes = V.map atomType --hm- no error-checking here addAttribute :: Attribute -> Attributes -> Attributes @@ -35,17 +35,14 @@ --if some attribute names overlap but the types do not, then spit back an error joinAttributes :: Attributes -> Attributes -> Either RelationalError Attributes -joinAttributes attrs1 attrs2 = if V.length uniqueOverlappingAttributes /= V.length overlappingAttributes then - Left (TupleAttributeTypeMismatchError overlappingAttributes) - else if V.length overlappingAttrsDifferentTypes > 0 then - Left (TupleAttributeTypeMismatchError overlappingAttrsDifferentTypes) - else - Right $ vectorUniqueify (attrs1 V.++ attrs2) +joinAttributes attrs1 attrs2 | V.length uniqueOverlappingAttributes /= V.length overlappingAttributes = Left (TupleAttributeTypeMismatchError overlappingAttributes) + | V.length overlappingAttrsDifferentTypes > 0 = Left (TupleAttributeTypeMismatchError overlappingAttrsDifferentTypes) + | otherwise = Right $ vectorUniqueify (attrs1 V.++ attrs2) where overlappingAttrsDifferentTypes = V.filter (\attr -> V.elem (attributeName attr) attrNames2 && V.notElem attr attrs2) attrs1 attrNames2 = V.map attributeName attrs2 uniqueOverlappingAttributes = vectorUniqueify overlappingAttributes - overlappingAttributes = V.filter (\attr -> V.elem attr attrs2) attrs1 + overlappingAttributes = V.filter (`V.elem` attrs2) attrs1 addAttributes :: Attributes -> Attributes -> Attributes addAttributes = (V.++) @@ -57,7 +54,7 @@ renameAttribute newAttrName (Attribute _ typeo) = Attribute newAttrName typeo renameAttributes :: AttributeName -> AttributeName -> Attributes -> Attributes -renameAttributes oldAttrName newAttrName attrs = V.map renamer attrs +renameAttributes oldAttrName newAttrName = V.map renamer where renamer attr = if attributeName attr == oldAttrName then renameAttribute newAttrName attr @@ -71,11 +68,11 @@ attributeForName :: AttributeName -> Attributes -> Either RelationalError Attribute attributeForName attrName attrs = case V.find (\attr -> attributeName attr == attrName) attrs of - Nothing -> Left $ NoSuchAttributeNamesError (S.singleton attrName) + Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName)) Just attr -> Right attr attributesForNames :: S.Set AttributeName -> Attributes -> Attributes -attributesForNames attrNameSet attrs = V.filter filt attrs +attributesForNames attrNameSet = V.filter filt where filt attr = S.member (attributeName attr) attrNameSet @@ -90,7 +87,7 @@ attributesContained attrs1 attrs2 = attributeNamesContained (attributeNameSet attrs1) (attributeNameSet attrs2) attributeNamesContained :: S.Set AttributeName -> S.Set AttributeName -> Bool -attributeNamesContained attrs1 attrs2 = S.isSubsetOf attrs1 attrs2 +attributeNamesContained = S.isSubsetOf --returns the disjunction of the AttributeNameSets nonMatchingAttributeNameSet :: S.Set AttributeName -> S.Set AttributeName -> S.Set AttributeName @@ -100,7 +97,7 @@ matchingAttributeNameSet = S.intersection attributeNamesNotContained :: S.Set AttributeName -> S.Set AttributeName -> S.Set AttributeName -attributeNamesNotContained subset superset = S.filter (flip S.notMember superset) subset +attributeNamesNotContained subset superset = S.filter (`S.notMember` superset) subset -- this is sorted so the tuples know in which order to output- the ordering is arbitrary sortedAttributeNameList :: S.Set AttributeName -> [AttributeName] diff --git a/src/lib/ProjectM36/Base.hs b/src/lib/ProjectM36/Base.hs --- a/src/lib/ProjectM36/Base.hs +++ b/src/lib/ProjectM36/Base.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ExistentialQuantification,BangPatterns,DeriveGeneric,DeriveAnyClass, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass, TypeSynonymInstances, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module ProjectM36.Base where import ProjectM36.DatabaseContextFunctionError @@ -34,10 +34,13 @@ DateTimeAtom UTCTime | ByteStringAtom ByteString | BoolAtom Bool | + IntervalAtom Atom Atom OpenInterval OpenInterval | RelationAtom Relation | ConstructedAtom DataConstructorName AtomType [Atom] deriving (Eq, Show, Binary, Typeable, NFData, Generic) +type OpenInterval = Bool + instance Hashable Atom where hashWithSalt salt (ConstructedAtom dConsName _ atoms) = salt `hashWithSalt` atoms `hashWithSalt` dConsName --AtomType is not hashable @@ -48,6 +51,7 @@ hashWithSalt salt (DateTimeAtom dt) = salt `hashWithSalt` dt hashWithSalt salt (ByteStringAtom bs) = salt `hashWithSalt` bs hashWithSalt salt (BoolAtom b) = salt `hashWithSalt` b + hashWithSalt salt (IntervalAtom a1 a2 bo be) = salt `hashWithSalt` a1 `hashWithSalt` a2 `hashWithSalt` bo `hashWithSalt` be hashWithSalt salt (RelationAtom r) = salt `hashWithSalt` r instance Binary UTCTime where @@ -71,6 +75,7 @@ DateTimeAtomType | ByteStringAtomType | BoolAtomType | + IntervalAtomType AtomType | RelationAtomType Attributes | ConstructedAtomType TypeConstructorName TypeVarMap | TypeVariableType TypeVarName @@ -106,7 +111,7 @@ attrsAsSet = HS.fromList . V.toList sortedAttributesIndices :: Attributes -> [(Int, Attribute)] -sortedAttributesIndices attrs = L.sortBy (\(_, (Attribute name1 _)) (_,(Attribute name2 _)) -> compare name1 name2) $ V.toList (V.indexed attrs) +sortedAttributesIndices attrs = L.sortBy (\(_, Attribute name1 _) (_,Attribute name2 _) -> compare name1 name2) $ V.toList (V.indexed attrs) -- | The relation's tuple set is the body of the relation. newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Hashable, Show, Generic, Binary) @@ -130,7 +135,7 @@ else salt `hashWithSalt` sortedAttrs `hashWithSalt` - (V.toList sortedTupVec) + V.toList sortedTupVec where sortedAttrsIndices = sortedAttributesIndices attrs sortedAttrs = map snd sortedAttrsIndices @@ -264,7 +269,7 @@ -- | The DatabaseContext is a snapshot of a database's evolving state and contains everything a database client can change over time. -- I spent some time thinking about whether the VirtualDatabaseContext/Schema and DatabaseContext data constructors should be the same constructor, but that would allow relation variables to be created in a "virtual" context which would appear to defeat the isomorphisms of the contexts. It should be possible to switch to an alternative schema to view the same equivalent information without information loss. However, allowing all contexts to reference another context while maintaining its own relation variables, new types, etc. could be interesting from a security perspective. For example, if a user creates a new relvar in a virtual context, then does it necessarily appear in all linked contexts? After deliberation, I think the relvar should appear in *all* linked contexts to retain the isomorphic properties, even when the isomorphism is for a subset of the context. This hints that the IsoMorphs should allow for "fall-through"; that is, when a relvar is not defined in the virtual context (for morphing), then the lookup should fall through to the underlying context. -data Schema = Schema SchemaIsomorphs +newtype Schema = Schema SchemaIsomorphs deriving (Generic, Binary) data SchemaIsomorph = IsoRestrict RelVarName RestrictionPredicateExpr (RelVarName, RelVarName) | @@ -362,8 +367,8 @@ transactionHeadsForGraph (TransactionGraph heads _) = heads -- | Every transaction has context-specific information attached to it. -data TransactionInfo = TransactionInfo TransactionId (S.Set TransactionId) | -- 1 parent + n children - MergeTransactionInfo TransactionId TransactionId (S.Set TransactionId) -- 2 parents, n children +data TransactionInfo = TransactionInfo TransactionId (S.Set TransactionId) UTCTime | -- 1 parent + n children + MergeTransactionInfo TransactionId TransactionId (S.Set TransactionId) UTCTime -- 2 parents, n children deriving(Show, Generic) instance Binary TransactionInfo @@ -440,7 +445,7 @@ } deriving (Generic, NFData) instance Hashable AtomFunction where - hashWithSalt salt func = salt `hashWithSalt` (atomFuncName func) + hashWithSalt salt func = salt `hashWithSalt` atomFuncName func instance Eq AtomFunction where f1 == f2 = atomFuncName f1 == atomFuncName f2 @@ -449,7 +454,7 @@ show aFunc = unpack (atomFuncName aFunc) ++ "::" ++ showArgTypes ++ "; " ++ body where body = show (atomFuncBody aFunc) - showArgTypes = concat (L.intersperse "->" $ map show (atomFuncType aFunc)) + showArgTypes = L.intercalate "->" (map show (atomFuncType aFunc)) -- | The 'AttributeNames' structure represents a set of attribute names or the same set of names but inverted in the context of a relational expression. For example, if a relational expression has attributes named "a", "b", and "c", the 'InvertedAttributeNames' of ("a","c") is ("b"). data AttributeNames = AttributeNames (S.Set AttributeName) | @@ -472,7 +477,7 @@ deriving (Eq, Show, Generic, Binary, NFData) -- | Dynamically create a tuple from attribute names and 'AtomExpr's. -data TupleExprBase a = TupleExpr (M.Map AttributeName (AtomExprBase a)) +newtype TupleExprBase a = TupleExpr (M.Map AttributeName (AtomExprBase a)) deriving (Eq, Show, Generic, NFData) instance Binary TupleExpr @@ -508,7 +513,7 @@ type DatabaseContextFunctions = HS.HashSet DatabaseContextFunction instance Hashable DatabaseContextFunction where - hashWithSalt salt func = salt `hashWithSalt` (dbcFuncName func) + hashWithSalt salt func = salt `hashWithSalt` dbcFuncName func instance Eq DatabaseContextFunction where f1 == f2 = dbcFuncName f1 == dbcFuncName f2 diff --git a/src/lib/ProjectM36/Client.hs b/src/lib/ProjectM36/Client.hs --- a/src/lib/ProjectM36/Client.hs +++ b/src/lib/ProjectM36/Client.hs @@ -31,6 +31,7 @@ setCurrentSchemaName, transactionGraphAsRelation, relationVariablesAsRelation, + disconnectedTransactionIsDirty, headName, remoteDBLookupName, defaultServerPort, @@ -44,6 +45,7 @@ DatabaseContextExpr(..), DatabaseContextIOExpr(..), Attribute(..), + MergeStrategy(..), attributesFromList, createNodeId, createSessionAtCommit, @@ -53,7 +55,7 @@ callTestTimeout_, RelationCardinality(..), TransactionGraphOperator(..), - CommitOption(..), + ProjectM36.Client.autoMergeToHead, transactionGraph_, disconnectedTransaction_, TransGraphRelationalExpr, @@ -87,7 +89,8 @@ Atomable(..), TupleExprBase(..), AtomExprBase(..), - RestrictionPredicateExprBase(..) + RestrictionPredicateExprBase(..), + withTransaction ) where import ProjectM36.Base hiding (inclusionDependencies) --defined in this module as well import qualified ProjectM36.Base as B @@ -101,6 +104,7 @@ import Control.Monad.Trans.Reader import qualified ProjectM36.RelationalExpression as RE import ProjectM36.DatabaseContext (basicDatabaseContext) +import qualified ProjectM36.TransactionGraph as Graph import ProjectM36.TransactionGraph import qualified ProjectM36.Transaction as Trans import ProjectM36.TransactionGraph.Persist @@ -123,11 +127,10 @@ import Control.Distributed.Process.Node (newLocalNode, initRemoteTable, runProcess, LocalNode, forkProcess, closeLocalNode) import Control.Distributed.Process.Extras.Internal.Types (whereisRemote) import Control.Distributed.Process.ManagedProcess.Client (call, safeCall) -import Control.Distributed.Process (NodeId(..), reconnect) - +import Data.Either (isRight) import Data.UUID.V4 (nextRandom) import Data.Word -import Control.Distributed.Process (ProcessId, Process, receiveWait, send, match) +import Control.Distributed.Process (ProcessId, Process, receiveWait, send, match, NodeId(..), reconnect) import Control.Exception (IOException, handle, AsyncException, throwIO, fromException, Exception) import Control.Concurrent.MVar import qualified Data.Map as M @@ -142,6 +145,7 @@ import GHC.Generics (Generic) import Control.DeepSeq (force) import System.IO +import Data.Time.Clock type Hostname = String @@ -175,7 +179,7 @@ type EvaluatedNotifications = M.Map NotificationName EvaluatedNotification -- | Used for callbacks from the server when monitored changes have been made. -data NotificationMessage = NotificationMessage EvaluatedNotifications +newtype NotificationMessage = NotificationMessage EvaluatedNotifications deriving (Binary, Eq, Show, Generic) -- | When a notification is fired, the 'reportExpr' is evaluated in the commit's context, so that is returned along with the original notification. @@ -255,9 +259,9 @@ notificationListener callback = do --pid <- getSelfPid --liftIO $ putStrLn $ "LISTENER THREAD START " ++ show pid - _ <- forever $ do + _ <- forever $ receiveWait [ - match (\(NotificationMessage eNots) -> do + match (\(NotificationMessage eNots) -> --say $ "NOTIFICATION: " ++ show eNots -- when notifications are thrown, they are not adjusted for the current schema which could be problematic, but we don't have access to the current session here liftIO $ mapM_ (uncurry callback) (M.toList eNots) @@ -266,14 +270,14 @@ --say "LISTENER THREAD EXIT" pure () -startNotificationListener :: LocalNode -> NotificationCallback -> IO (ProcessId) +startNotificationListener :: LocalNode -> NotificationCallback -> IO ProcessId startNotificationListener localNode callback = forkProcess localNode (notificationListener callback) createScriptSession :: [String] -> IO (Maybe ScriptSession) createScriptSession ghcPkgPaths = do eScriptSession <- initScriptSession ghcPkgPaths case eScriptSession of - Left err -> hPutStrLn stderr ("Failed to load scripting engine- scripting disabled: " ++ (show err)) >> pure Nothing --not a fatal error, but the scripting feature must be disabled + Left err -> hPutStrLn stderr ("Failed to load scripting engine- scripting disabled: " ++ show err) >> pure Nothing --not a fatal error, but the scripting feature must be disabled Right s -> pure (Just s) -- | To create a 'Connection' to a remote or local database, create a 'ConnectionInfo' and call 'connectProjectM36'. @@ -281,8 +285,9 @@ --create a new in-memory database/transaction graph connectProjectM36 (InProcessConnectionInfo strat notificationCallback ghcPkgPaths) = do freshId <- nextRandom + stamp <- getCurrentTime let bootstrapContext = basicDatabaseContext - freshGraph = bootstrapTransactionGraph freshId bootstrapContext + freshGraph = bootstrapTransactionGraph stamp freshId bootstrapContext case strat of --create date examples graph for now- probably should be empty context in the future NoPersistence -> do @@ -293,7 +298,7 @@ notificationPid <- startNotificationListener localNode notificationCallback mScriptSession <- createScriptSession ghcPkgPaths - let conn = InProcessConnection (InProcessConnectionConf { + let conn = InProcessConnection InProcessConnectionConf { ipPersistenceStrategy = strat, ipClientNodes = clientNodes, ipSessions = sessions, @@ -301,7 +306,7 @@ ipScriptSession = mScriptSession, ipLocalNode = localNode, ipTransport = transport, - ipLocks = Nothing}) + ipLocks = Nothing} addClientNode conn notificationPid pure (Right conn) MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshGraph notificationCallback ghcPkgPaths @@ -322,8 +327,8 @@ loginConfirmation <- safeLogin (Login notificationListenerPid) serverProcessId if not loginConfirmation then liftIO $ putMVar connStatus (Left LoginError) - else do - liftIO $ putMVar connStatus (Right $ RemoteProcessConnection (RemoteProcessConnectionConf {rLocalNode = localNode, rProcessId = serverProcessId, rTransport = transport})) + else + liftIO $ putMVar connStatus (Right $ RemoteProcessConnection RemoteProcessConnectionConf {rLocalNode = localNode, rProcessId = serverProcessId, rTransport = transport}) status <- takeMVar connStatus pure status @@ -349,7 +354,7 @@ clientNodes <- STMSet.newIO (localNode, transport) <- createLocalNode lockMVar <- newMVar digest - let conn = InProcessConnection (InProcessConnectionConf { + let conn = InProcessConnection InProcessConnectionConf { ipPersistenceStrategy = strat, ipClientNodes = clientNodes, ipSessions = sessions, @@ -358,19 +363,18 @@ ipLocalNode = localNode, ipTransport = transport, ipLocks = Just (lockFileH, lockMVar) - }) + } 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 :: TransactionId -> Connection -> IO (Either RelationalError SessionId) -createSessionAtCommit commitId conn@(InProcessConnection _) = do +createSessionAtCommit :: Connection -> TransactionId -> IO (Either RelationalError SessionId) +createSessionAtCommit conn@(InProcessConnection _) commitId = do newSessionId <- nextRandom - atomically $ do - createSessionAtCommit_ commitId newSessionId conn -createSessionAtCommit uuid conn@(RemoteProcessConnection _) = remoteCall conn (CreateSessionAtCommit uuid) + atomically $ createSessionAtCommit_ commitId newSessionId conn +createSessionAtCommit conn@(RemoteProcessConnection _) uuid = remoteCall conn (CreateSessionAtCommit uuid) createSessionAtCommit_ :: TransactionId -> SessionId -> Connection -> STM (Either RelationalError SessionId) createSessionAtCommit_ commitId newSessionId (InProcessConnection conf) = do @@ -390,8 +394,8 @@ createSessionAtCommit_ _ _ (RemoteProcessConnection _) = error "createSessionAtCommit_ called on remote connection" -- | Call 'createSessionAtHead' with a transaction graph's head's name to create a new session pinned to that head. This function returns a 'SessionId' which can be used in other function calls to reference the point in the transaction graph. -createSessionAtHead :: HeadName -> Connection -> IO (Either RelationalError SessionId) -createSessionAtHead headn conn@(InProcessConnection conf) = do +createSessionAtHead :: Connection -> HeadName -> IO (Either RelationalError SessionId) +createSessionAtHead conn@(InProcessConnection conf) headn = do let graphTvar = ipTransactionGraph conf newSessionId <- nextRandom atomically $ do @@ -399,7 +403,7 @@ case transactionForHead headn graph of Nothing -> pure $ Left (NoSuchHeadNameError headn) Just trans -> createSessionAtCommit_ (transactionId trans) newSessionId conn -createSessionAtHead headn conn@(RemoteProcessConnection _) = remoteCall conn (CreateSessionAtHead headn) +createSessionAtHead conn@(RemoteProcessConnection _) headn = remoteCall conn (CreateSessionAtHead headn) -- | Used internally for server connections to keep track of remote nodes for the purpose of sending notifications later. addClientNode :: Connection -> ProcessId -> IO () @@ -408,7 +412,7 @@ -- | Discards a session, eliminating any uncommitted changes present in the session. closeSession :: SessionId -> Connection -> IO () -closeSession sessionId (InProcessConnection conf) = do +closeSession sessionId (InProcessConnection conf) = atomically $ STMMap.delete sessionId (ipSessions conf) closeSession sessionId conn@(RemoteProcessConnection _) = remoteCall conn (CloseSession sessionId) -- | 'close' cleans up the database access connection and closes any relevant sockets. @@ -422,7 +426,7 @@ closeTransport (ipTransport conf) close conn@(RemoteProcessConnection conf) = do - _ <- (remoteCall conn Logout) :: IO Bool + _ <- remoteCall conn Logout :: IO Bool closeLocalNode (rLocalNode conf) closeTransport (rTransport conf) @@ -435,14 +439,8 @@ --within the database server, we must catch and handle all exception lest they take down the database process- this handling might be different for other use-cases --exceptions should generally *NOT* be thrown from any Project:M36 code paths, but third-party code such as AtomFunction scripts could conceivably throw undefined, etc. -excMaybe :: IO (Maybe RelationalError) -> IO (Maybe RelationalError) -excMaybe m = handle handler m - where - handler exc | Just (_ :: AsyncException) <- fromException exc = throwIO exc - | otherwise = pure (Just (UnhandledExceptionError (show exc))) - excEither :: IO (Either RelationalError a) -> IO (Either RelationalError a) -excEither m = handle handler m +excEither = handle handler where handler exc | Just (_ :: AsyncException) <- fromException exc = throwIO exc | otherwise = pure (Left (UnhandledExceptionError (show exc))) @@ -455,7 +453,7 @@ liftIO $ putMVar ret val takeMVar ret -safeLogin :: Login -> ProcessId -> Process (Bool) +safeLogin :: Login -> ProcessId -> Process Bool safeLogin login procId = do ret <- call procId login case ret of @@ -503,25 +501,25 @@ Right schema -> pure (Right (session, schema)) -- | Returns the name of the currently selected isomorphic schema. -currentSchemaName :: SessionId -> Connection -> IO (Maybe SchemaName) +currentSchemaName :: SessionId -> Connection -> IO (Either RelationalError SchemaName) currentSchemaName sessionId (InProcessConnection conf) = atomically $ do let sessions = ipSessions conf eSession <- sessionForSessionId sessionId sessions case eSession of - Left _ -> pure Nothing - Right session -> pure (Just (Sess.schemaName session)) + Left err -> pure (Left err) + Right session -> pure (Right (Sess.schemaName session)) currentSchemaName sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveCurrentSchemaName sessionId) -- | Switch to the named isomorphic schema. -setCurrentSchemaName :: SessionId -> Connection -> SchemaName -> IO (Maybe RelationalError) +setCurrentSchemaName :: SessionId -> Connection -> SchemaName -> IO (Either RelationalError ()) setCurrentSchemaName sessionId (InProcessConnection conf) sname = atomically $ do let sessions = ipSessions conf eSession <- sessionForSessionId sessionId sessions case eSession of - Left _ -> pure Nothing + Left err -> pure (Left err) Right session -> case Sess.setSchemaName sname session of - Left err -> pure (Just err) - Right newSession -> STMMap.insert newSession sessionId sessions >> pure Nothing + Left err -> pure (Left err) + Right newSession -> STMMap.insert newSession sessionId sessions >> pure (Right ()) setCurrentSchemaName sessionId conn@(RemoteProcessConnection _) sname = remoteCall conn (ExecuteSetCurrentSchema sessionId sname) -- | Execute a relational expression in the context of the session and connection. Relational expressions are queries and therefore cannot alter the database. @@ -544,55 +542,74 @@ executeRelationalExpr sessionId conn@(RemoteProcessConnection _) relExpr = remoteCall conn (ExecuteRelationalExpr sessionId relExpr) -- | Execute a database context expression in the context of the session and connection. Database expressions modify the current session's disconnected transaction but cannot modify the transaction graph. -executeDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Maybe RelationalError) -executeDatabaseContextExpr sessionId (InProcessConnection conf) expr = excMaybe $ atomically $ do +executeDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Either RelationalError ()) +executeDatabaseContextExpr sessionId (InProcessConnection conf) expr = excEither $ atomically $ do let sessions = ipSessions conf eSession <- sessionAndSchema sessionId sessions case eSession of - Left err -> pure $ Just err + Left err -> pure (Left err) Right (session, schema) -> do let expr' = if schemaName session == defaultSchemaName then Right expr else Schema.processDatabaseContextExprInSchema schema expr case expr' of - Left err -> pure (Just err) + Left err -> pure (Left err) Right expr'' -> case runState (RE.evalDatabaseContextExpr expr'') (RE.freshDatabaseState (Sess.concreteDatabaseContext session)) of - (Just err,_) -> return $ Just err - (Nothing, (_,_,False)) -> pure Nothing --optimization- if nothing was dirtied, nothing to do + (Just err,_) -> pure (Left err) + (Nothing, (_,_,False)) -> pure (Right ()) --optimization- if nothing was dirtied, nothing to do (Nothing, (!context',_,True)) -> do let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas True newSubschemas = Schema.processDatabaseContextExprSchemasUpdate (Sess.subschemas session) expr newSchemas = Schemas context' newSubschemas newSession = Session newDiscon (Sess.schemaName session) STMMap.insert newSession sessionId sessions - pure Nothing - + pure (Right ()) executeDatabaseContextExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr sessionId dbExpr) +-- | Similar to a git rebase, 'autoMergeToHead' atomically creates a temporary branch and merges it to the latest commit of the branch referred to by the 'HeadName' and commits the merge. This is useful to reduce incidents of 'TransactionIsNotAHeadError's but at the risk of merge errors (thus making it similar to rebasing). +autoMergeToHead :: SessionId -> Connection -> MergeStrategy -> HeadName -> IO (Either RelationalError ()) +autoMergeToHead sessionId (InProcessConnection conf) strat headName' = do + let sessions = ipSessions conf + id1 <- nextRandom + id2 <- nextRandom + id3 <- nextRandom + stamp <- getCurrentTime + commitLock_ sessionId conf $ \graph -> do + eSession <- sessionForSessionId sessionId sessions + case eSession of + Left err -> pure (Left err) + Right session -> + case Graph.autoMergeToHead stamp (id1, id2, id3) (Sess.disconnectedTransaction session) headName' strat graph of + Left err -> pure (Left err) + Right (discon', graph') -> + pure (Right (discon', graph', [id1, id2, id3])) +autoMergeToHead sessionId conn@(RemoteProcessConnection _) strat headName' = remoteCall conn (ExecuteAutoMergeToHead sessionId strat headName') + -- | Execute a database context IO-monad-based expression for the given session and connection. `DatabaseContextIOExpr`s modify the DatabaseContext but cannot be purely implemented. --this is almost completely identical to executeDatabaseContextExpr above -executeDatabaseContextIOExpr :: SessionId -> Connection -> DatabaseContextIOExpr -> IO (Maybe RelationalError) -executeDatabaseContextIOExpr sessionId (InProcessConnection conf) expr = excMaybe $ do +executeDatabaseContextIOExpr :: SessionId -> Connection -> DatabaseContextIOExpr -> IO (Either RelationalError ()) +executeDatabaseContextIOExpr sessionId (InProcessConnection conf) expr = excEither $ do let sessions = ipSessions conf scriptSession = ipScriptSession conf eSession <- atomically $ sessionForSessionId sessionId sessions --potentially race condition due to interleaved IO? case eSession of - Left err -> pure $ Just err + Left err -> pure (Left err) Right session -> do res <- RE.evalDatabaseContextIOExpr scriptSession (Sess.concreteDatabaseContext session) expr case res of - Left err -> pure (Just err) + Left err -> pure (Left err) Right context' -> do let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas True newSchemas = Schemas context' (Sess.subschemas session) newSession = Session newDiscon (Sess.schemaName session) atomically $ STMMap.insert newSession sessionId sessions - pure Nothing + pure (Right ()) executeDatabaseContextIOExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextIOExpr sessionId dbExpr) -executeGraphExprSTM_ :: Bool -> TransactionId -> SessionId -> Session -> Sessions -> TransactionGraphOperator -> TransactionGraph -> TVar TransactionGraph -> STM (Either RelationalError TransactionGraph) -executeGraphExprSTM_ updateGraphOnError freshId sessionId session sessions graphExpr graph graphTVar= do +{- +executeGraphExprSTM_ :: TransactionId -> SessionId -> Session -> Sessions -> TransactionGraphOperator -> TransactionGraph -> TVar TransactionGraph -> STM (Either RelationalError (TransactionGraph, DisconnectedTransaction) +executeGraphExprSTM_ freshId sessionId session sessions graphExpr graph graphTVar= do case evalGraphOp freshId (Sess.disconnectedTransaction session) graph graphExpr of Left err -> do when updateGraphOnError (writeTVar graphTVar graph) @@ -602,6 +619,7 @@ let newSession = Session discon' (Sess.schemaName session) STMMap.insert newSession sessionId sessions pure $ Right graph' +-} -- process notifications for commits executeCommitExprSTM_ :: DatabaseContext -> DatabaseContext -> ClientNodes -> STM (EvaluatedNotifications, ClientNodes) @@ -618,15 +636,32 @@ -- OPTIMIZATION OPPORTUNITY: no locks are required to write new transaction data, only to update the transaction graph id file -- if writing data is re-entrant, we may be able to use unsafeIOtoSTM -- perhaps keep hash of data file instead of checking if our head was updated on every write -executeGraphExpr :: SessionId -> Connection -> TransactionGraphOperator -> IO (Maybe RelationalError) -executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excMaybe $ do +executeGraphExpr :: SessionId -> Connection -> TransactionGraphOperator -> IO (Either RelationalError ()) +executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excEither $ do + let sessions = ipSessions conf + freshId <- nextRandom + stamp <- getCurrentTime + commitLock_ sessionId conf $ \updatedGraph -> do + eSession <- sessionForSessionId sessionId sessions + case eSession of + Left err -> pure (Left err) + Right session -> do + let discon = Sess.disconnectedTransaction session + case evalGraphOp stamp freshId discon updatedGraph graphExpr of + Left err -> pure (Left err) + Right (discon', graph') -> do + --if freshId appears in the graph, then we need to pass it on + let transIds = [freshId | isRight (transactionForId freshId graph')] + pure (Right (discon', graph', transIds)) +{- +executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excEither $ do let strat = ipPersistenceStrategy conf clientNodes = ipClientNodes conf sessions = ipSessions conf graphTvar = ipTransactionGraph conf mLockFileH = ipLocks conf lockHandler body = case graphExpr of - Commit _ -> case mLockFileH of + Commit -> case mLockFileH of Nothing -> body False Just (lockFileH, lockMVar) -> let acquireLocks = do lastWrittenDigest <- takeMVar lockMVar @@ -665,19 +700,14 @@ case eRefreshedGraph of Left err -> pure (Left (DatabaseLoadError err)) Right refreshedGraph -> do - if not (isDirty session) && graphExpr == Commit IgnoreEmptyCommitOption then - pure (Right (M.empty, [], oldGraph)) - else do + --snip it eGraph <- executeGraphExprSTM_ dbWrittenByOtherProcess freshId sessionId session sessions graphExpr refreshedGraph graphTvar + --snip it case eGraph of Left err -> pure (Left err) Right newGraph -> do --handle commit - if not (isDirty session) && graphExpr == Commit ForbidEmptyCommitOption then - pure (Left EmptyCommitError) - else if not (isDirty session) && graphExpr == Commit IgnoreEmptyCommitOption then - pure (Right (M.empty, [], newGraph)) - else if isCommit graphExpr then do + if isCommit graphExpr then do case transactionForId (Sess.parentId session) oldGraph of Left err -> pure $ Left err Right previousTrans -> do @@ -693,6 +723,7 @@ processTransactionGraphPersistence strat newGraph sendNotifications nodesToNotify (ipLocalNode conf) notsToFire pure Nothing +-} executeGraphExpr sessionId conn@(RemoteProcessConnection _) graphExpr = remoteCall conn (ExecuteGraphExpr sessionId graphExpr) -- | A trans-graph expression is a relational query executed against the entirety of a transaction graph. @@ -708,48 +739,48 @@ executeTransGraphRelationalExpr sessionId conn@(RemoteProcessConnection _) tgraphExpr = remoteCall conn (ExecuteTransGraphRelationalExpr sessionId tgraphExpr) -- | Schema expressions manipulate the isomorphic schemas for the current 'DatabaseContext'. -executeSchemaExpr :: SessionId -> Connection -> Schema.SchemaExpr -> IO (Maybe RelationalError) +executeSchemaExpr :: SessionId -> Connection -> Schema.SchemaExpr -> IO (Either RelationalError ()) executeSchemaExpr sessionId (InProcessConnection conf) schemaExpr = atomically $ do let sessions = ipSessions conf eSession <- sessionAndSchema sessionId sessions case eSession of - Left err -> pure (Just err) + Left err -> pure (Left err) Right (session, _) -> do let subschemas' = subschemas session case Schema.evalSchemaExpr schemaExpr (Sess.concreteDatabaseContext session) subschemas' of - Left err -> pure (Just err) + Left err -> pure (Left err) Right (newSubschemas, newContext) -> do --hm- maybe we should start using lenses let discon = Sess.disconnectedTransaction session newSchemas = Schemas newContext newSubschemas newSession = Session (DisconnectedTransaction (Discon.parentId discon) newSchemas True) (Sess.schemaName session) STMMap.insert newSession sessionId sessions - pure Nothing + pure (Right ()) executeSchemaExpr sessionId conn@(RemoteProcessConnection _) schemaExpr = remoteCall conn (ExecuteSchemaExpr sessionId schemaExpr) -- | After modifying a 'DatabaseContext', 'commit' the transaction to the transaction graph at the head which the session is referencing. This will also trigger checks for any notifications which need to be propagated. -commit :: SessionId -> Connection -> CommitOption -> IO (Maybe RelationalError) -commit sessionId conn@(InProcessConnection _) cOpt = executeGraphExpr sessionId conn (Commit cOpt) -commit sessionId conn@(RemoteProcessConnection _) cOpt = remoteCall conn (ExecuteGraphExpr sessionId (Commit cOpt)) +commit :: SessionId -> Connection -> IO (Either RelationalError ()) +commit sessionId conn@(InProcessConnection _) = executeGraphExpr sessionId conn Commit +commit sessionId conn@(RemoteProcessConnection _) = remoteCall conn (ExecuteGraphExpr sessionId Commit) sendNotifications :: [ProcessId] -> LocalNode -> EvaluatedNotifications -> IO () sendNotifications pids localNode nots = mapM_ sendNots pids where - sendNots remoteClientPid = do - when (not (M.null nots)) $ runProcess localNode $ send remoteClientPid (NotificationMessage nots) + sendNots remoteClientPid = + unless (M.null nots) $ runProcess localNode $ send remoteClientPid (NotificationMessage nots) -- | Discard any changes made in the current 'Session' and 'DatabaseContext'. This resets the disconnected transaction to reference the original database context of the parent transaction and is a very cheap operation. -rollback :: SessionId -> Connection -> IO (Maybe RelationalError) +rollback :: SessionId -> Connection -> IO (Either RelationalError ()) rollback sessionId conn@(InProcessConnection _) = executeGraphExpr sessionId conn Rollback rollback sessionId conn@(RemoteProcessConnection _) = remoteCall conn (ExecuteGraphExpr sessionId Rollback) -- | Write the transaction graph to disk. This function can be used to incrementally write new transactions to disk. -processTransactionGraphPersistence :: PersistenceStrategy -> TransactionGraph -> IO () -processTransactionGraphPersistence NoPersistence _ = pure () -processTransactionGraphPersistence (MinimalPersistence dbdir) graph = transactionGraphPersist NoDiskSync dbdir graph >> pure () -processTransactionGraphPersistence (CrashSafePersistence dbdir) graph = transactionGraphPersist FsyncDiskSync dbdir graph >> pure () +processTransactionGraphPersistence :: PersistenceStrategy -> [TransactionId] -> TransactionGraph -> IO () +processTransactionGraphPersistence NoPersistence _ _ = pure () +processTransactionGraphPersistence (MinimalPersistence dbdir) transIds graph = transactionGraphPersist NoDiskSync dbdir transIds graph >> pure () +processTransactionGraphPersistence (CrashSafePersistence dbdir) transIds graph = transactionGraphPersist FsyncDiskSync dbdir transIds graph >> pure () -readGraphTransactionIdDigest :: PersistenceStrategy -> IO (LockFileHash) +readGraphTransactionIdDigest :: PersistenceStrategy -> IO LockFileHash readGraphTransactionIdDigest NoPersistence = error "attempt to read digest from transaction log without persistence enabled" readGraphTransactionIdDigest (MinimalPersistence dbdir) = readGraphTransactionIdFileDigest dbdir readGraphTransactionIdDigest (CrashSafePersistence dbdir) = readGraphTransactionIdFileDigest dbdir @@ -847,28 +878,30 @@ relationVariablesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveRelationVariableSummary sessionId) -- | Returns the transaction id for the connection's disconnected transaction committed parent transaction. -headTransactionId :: SessionId -> Connection -> IO (Maybe TransactionId) +headTransactionId :: SessionId -> Connection -> IO (Either RelationalError TransactionId) headTransactionId sessionId (InProcessConnection conf) = do let sessions = ipSessions conf atomically $ do eSession <- sessionForSessionId sessionId sessions case eSession of - Left _ -> pure Nothing - Right session -> pure $ Just (Sess.parentId session) + Left err -> pure (Left err) + Right session -> pure $ Right (Sess.parentId session) headTransactionId sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveHeadTransactionId sessionId) -headNameSTM_ :: SessionId -> Sessions -> TVar TransactionGraph -> STM (Maybe HeadName) +headNameSTM_ :: SessionId -> Sessions -> TVar TransactionGraph -> STM (Either RelationalError HeadName) headNameSTM_ sessionId sessions graphTvar = do graph <- readTVar graphTvar eSession <- sessionForSessionId sessionId sessions case eSession of - Left _ -> pure $ Nothing - Right session -> pure $ case transactionForId (Sess.parentId session) graph of - Left _ -> Nothing - Right parentTrans -> headNameForTransaction parentTrans graph + Left err -> pure (Left err) + Right session -> case transactionForId (Sess.parentId session) graph of + Left err -> pure (Left err) + Right parentTrans -> case headNameForTransaction parentTrans graph of + Nothing -> pure (Left UnknownHeadError) + Just headName' -> pure (Right headName') -- | Returns Just the name of the head of the current disconnected transaction or Nothing. -headName :: SessionId -> Connection -> IO (Maybe HeadName) +headName :: SessionId -> Connection -> IO (Either RelationalError HeadName) headName sessionId (InProcessConnection conf) = do let sessions = ipSessions conf graphTvar = ipTransactionGraph conf @@ -883,11 +916,22 @@ eSession <- sessionForSessionId sessionId sessions case eSession of Left err -> pure (Left err) - Right session -> do + Right session -> case typesAsRelation (typeConstructorMapping (Sess.concreteDatabaseContext session)) of Left err -> pure (Left err) Right rel -> pure (Right rel) atomTypesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveAtomTypesAsRelation sessionId) + +disconnectedTransactionIsDirty :: SessionId -> Connection -> IO (Either RelationalError Bool) +disconnectedTransactionIsDirty sessionId (InProcessConnection conf) = do + let sessions = ipSessions conf + atomically $ do + eSession <- sessionForSessionId sessionId sessions + case eSession of + Left err -> pure (Left err) + Right session -> + pure (Right (isDirty session)) +disconnectedTransactionIsDirty sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveSessionIsDirty sessionId) --used only for testing- we expect this to throw an exception callTestTimeout_ :: SessionId -> Connection -> IO Bool @@ -903,9 +947,110 @@ disconnectedTransaction_ :: SessionId -> Connection -> IO DisconnectedTransaction disconnectedTransaction_ sessionId (InProcessConnection conf) = do let sessions = ipSessions conf - mSession <- atomically $ do - STMMap.lookup sessionId sessions + mSession <- atomically $ STMMap.lookup sessionId sessions case mSession of Nothing -> error "No such session" Just (Sess.Session discon _) -> pure discon disconnectedTransaction_ _ _= error "remote connection used" + +-- wrap a graph evaluation in file locking +commitLock_ :: SessionId -> + InProcessConnectionConf -> + (TransactionGraph -> + STM (Either RelationalError (DisconnectedTransaction, TransactionGraph, [TransactionId]))) -> + IO (Either RelationalError ()) +commitLock_ sessionId conf stmBlock = do + let sessions = ipSessions conf + strat = ipPersistenceStrategy conf + mScriptSession = ipScriptSession conf + graphTvar = ipTransactionGraph conf + clientNodes = ipClientNodes conf + mLockFileH = ipLocks conf + lockHandler body = case mLockFileH of + Nothing -> body False + Just (lockFileH, lockMVar) -> + let acquireLocks = do + lastWrittenDigest <- takeMVar lockMVar + lockFile lockFileH WriteLock + latestDigest <- readGraphTransactionIdDigest strat + pure (latestDigest /= lastWrittenDigest) + releaseLocks _ = do + --still holding the lock- get the latest digest + gDigest <- readGraphTransactionIdDigest strat + unlockFile lockFileH + putMVar lockMVar gDigest + in bracket acquireLocks releaseLocks body + manip <- lockHandler $ \dbWrittenByOtherProcess -> atomically $ do + eSession <- sessionForSessionId sessionId sessions + --handle graph update by other process + oldGraph <- readTVar graphTvar + case eSession of + Left err -> pure (Left err) + Right session -> do + let dbdir = case strat of + MinimalPersistence x -> x + CrashSafePersistence x -> x + _ -> error "accessing dbdir on non-persisted connection" + --this should also happen for non-commit expressions + eRefreshedGraph <- if dbWrittenByOtherProcess then + unsafeIOToSTM (transactionGraphLoad dbdir oldGraph mScriptSession) + else + pure (Right oldGraph) + case eRefreshedGraph of + Left err -> pure (Left (DatabaseLoadError err)) + Right refreshedGraph -> do + eGraph <- stmBlock refreshedGraph + case eGraph of + Left err -> pure (Left err) + Right (discon', graph', transactionIdsToPersist) -> do + writeTVar graphTvar graph' + let newSession = Session discon' (Sess.schemaName session) + STMMap.insert newSession sessionId sessions + case transactionForId (Sess.parentId session) oldGraph of + Left err -> pure $ Left err + Right previousTrans -> + if not (Prelude.null transactionIdsToPersist) then do + (evaldNots, nodes) <- executeCommitExprSTM_ (Trans.concreteDatabaseContext previousTrans) (Sess.concreteDatabaseContext session) clientNodes + nodesToNotify <- toList (STMSet.stream nodes) + pure $ Right (evaldNots, nodesToNotify, graph', transactionIdsToPersist) + else pure (Right (M.empty, [], graph', [])) + + --handle notification firing + case manip of + Left err -> pure (Left err) + Right (notsToFire, nodesToNotify, newGraph, transactionIdsToPersist) -> do + --update filesystem database, if necessary + processTransactionGraphPersistence strat transactionIdsToPersist newGraph + sendNotifications nodesToNotify (ipLocalNode conf) notsToFire + pure (Right ()) +{- +writeDisconAndGraph_ :: TVar TransactionGraph -> SessionId -> Session -> Sessions -> DisconnectedTransaction -> TransactionGraph -> STM () +writeDisconAndGraph_ graphTvar sessionId session sessions discon graph = do + writeTVar graphTvar graph + let newSession = Session discon (Sess.schemaName session) + STMMap.insert newSession sessionId sessions +-} + +-- | Runs an IO monad, commits the result when the monad returns no errors, otherwise, rolls back the changes and the error. +withTransaction :: SessionId -> Connection -> IO (Either RelationalError a) -> IO (Either RelationalError ()) -> IO (Either RelationalError a) +withTransaction sessionId conn io successFunc = bracketOnError (pure ()) (const do_rollback) block + where + do_rollback = rollback sessionId conn + block _ = do + eErr <- io + case eErr of + Left err -> do + _ <- do_rollback + pure (Left err) + Right val -> do + eIsDirty <- disconnectedTransactionIsDirty sessionId conn + case eIsDirty of + Left err -> pure (Left err) + Right dirty -> + if dirty then do + res <- successFunc + case res of + Left err -> pure (Left err) + Right _ -> pure (Right val) + else -- no updates executed, so don't create a commit + pure (Right val) diff --git a/src/lib/ProjectM36/Client/Simple.hs b/src/lib/ProjectM36/Client/Simple.hs new file mode 100644 --- /dev/null +++ b/src/lib/ProjectM36/Client/Simple.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module ProjectM36.Client.Simple ( + simpleConnectProjectM36, + withTransaction, + execute, + query, + rollback, + close, + Atom(..), + AtomType(..), + DbError(..), + Attribute(..), + C.ConnectionInfo(..), + C.PersistenceStrategy(..), + C.NotificationCallback, + C.emptyNotificationCallback, + C.DatabaseContextExpr(..), + C.RelationalExprBase(..) + ) where +-- | A simplified client interface for Project:M36 database access. +import ProjectM36.Error +import ProjectM36.Base +import qualified ProjectM36.Client as C +import Control.Monad.Reader +import Control.Exception.Base + +type DbConn = (C.SessionId, C.Connection) + +newtype Db a = Db {runDB :: ReaderT DbConn IO a} + deriving (Functor, Applicative, Monad, MonadIO) + +newtype TransactionCancelled = TransactionCancelled DbError deriving Show +instance Exception TransactionCancelled + +-- | A simple alternative to 'connectProjectM36' which includes simple session management +simpleConnectProjectM36 :: C.ConnectionInfo -> IO (Either DbError DbConn) +simpleConnectProjectM36 connInfo = do + eConn <- C.connectProjectM36 connInfo + case eConn of + Left err -> pure (Left (ConnError err)) + Right conn -> do + eSess <- C.createSessionAtHead conn "master" + case eSess of + Left err -> do + C.close conn + pure (Left (RelError err)) + Right sess -> pure (Right (sess, conn)) + +close :: DbConn -> IO () +close (_ , conn) = C.close conn + +-- | Runs a Db monad which may include some database updates. If an exception or error occurs, the transaction is rolled back. Otherwise, the transaction is committed to the head of the current branch. +withTransaction :: DbConn -> Db a -> IO (Either DbError a) +withTransaction sessconn = withTransactionUsing sessconn UnionMergeStrategy + +-- | Same a 'withTransaction' except that the merge strategy can be specified. +withTransactionUsing :: DbConn -> MergeStrategy -> Db a -> IO (Either DbError a) +withTransactionUsing (sess, conn) strat dbm = do + eHeadName <- C.headName sess conn + case eHeadName of + Left err -> pure (Left (RelError err)) + Right headName -> do + let successFunc = C.autoMergeToHead sess conn strat headName + block = runReaderT (runDB dbm) (sess, conn) + handler :: TransactionCancelled -> IO (Either DbError a) + handler (TransactionCancelled err) = pure (Left err) + handle handler $ do + ret <- C.withTransaction sess conn (block >>= pure . Right) successFunc + case ret of + Left err -> pure (Left (RelError err)) + Right val -> pure (Right val) + +-- | A union of connection and other errors that can be returned from 'withDBConnection'. +data DbError = ConnError C.ConnectionError | + RelError RelationalError | + TransactionRolledBack + deriving (Eq, Show) + +-- | Execute a 'DatabaseContextExpr' in the 'DB' monad. Database context expressions manipulate the state of the database. In case of an error, the transaction is terminated and the connection's session is rolled back. +execute :: C.DatabaseContextExpr -> Db () +execute expr = do + ret <- executeOrErr expr + case ret of + Left err -> liftIO $ cancelTransaction (RelError err) + Right _ -> pure () + +-- | Run a 'RelationalExpr' query in the 'DB' monad. Relational expressions perform read-only queries against the current database state. +query :: C.RelationalExpr -> Db Relation +query expr = do + ret <- queryOrErr expr + case ret of + Left err -> liftIO $ cancelTransaction (RelError err) + Right rel -> pure rel + +-- | Run a 'DatabaseContextExpr' update expression. If there is an error, just return it without cancelling the current transaction. +executeOrErr :: C.DatabaseContextExpr -> Db (Either RelationalError ()) +executeOrErr expr = Db $ do + (sess, conn) <- ask + lift $ C.executeDatabaseContextExpr sess conn expr + +-- | Run a 'RelationalExpr' query expression. If there is an error, just return it without cancelling the transaction. +queryOrErr :: C.RelationalExpr -> Db (Either RelationalError Relation) +queryOrErr expr = Db $ do + (sess, conn) <- ask + lift $ C.executeRelationalExpr sess conn expr + +-- | Unconditionally roll back the current transaction and throw an exception to terminate the execution of the Db monad. +rollback :: Db () +rollback = Db $ lift $ cancelTransaction TransactionRolledBack + +cancelTransaction :: DbError -> IO a +cancelTransaction err = throwIO (TransactionCancelled err) diff --git a/src/lib/ProjectM36/DataTypes/Basic.hs b/src/lib/ProjectM36/DataTypes/Basic.hs --- a/src/lib/ProjectM36/DataTypes/Basic.hs +++ b/src/lib/ProjectM36/DataTypes/Basic.hs @@ -8,10 +8,10 @@ import ProjectM36.Base basicTypeConstructorMapping :: TypeConstructorMapping -basicTypeConstructorMapping = (primitiveTypeConstructorMapping ++ - maybeTypeConstructorMapping ++ - eitherTypeConstructorMapping ++ - listTypeConstructorMapping ++ - dayTypeConstructorMapping - ) +basicTypeConstructorMapping = primitiveTypeConstructorMapping ++ + maybeTypeConstructorMapping ++ + eitherTypeConstructorMapping ++ + listTypeConstructorMapping ++ + dayTypeConstructorMapping + diff --git a/src/lib/ProjectM36/DataTypes/ByteString.hs b/src/lib/ProjectM36/DataTypes/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/lib/ProjectM36/DataTypes/ByteString.hs @@ -0,0 +1,18 @@ +module ProjectM36.DataTypes.ByteString where +import ProjectM36.Base +import ProjectM36.AtomFunctionError +import ProjectM36.AtomFunctionBody +import qualified Data.HashSet as HS +import qualified Data.ByteString.Base64 as B64 +import qualified Data.Text.Encoding as TE + +bytestringAtomFunctions :: AtomFunctions +bytestringAtomFunctions = HS.fromList [ + AtomFunction { atomFuncName = "bytestring", + atomFuncType = [TextAtomType, ByteStringAtomType], + atomFuncBody = compiledAtomFunctionBody $ \(TextAtom textIn:_) -> case B64.decode (TE.encodeUtf8 textIn) of + Left err -> Left (AtomFunctionBytesDecodingError err) + Right bs -> pure (ByteStringAtom bs) + } + ] + diff --git a/src/lib/ProjectM36/DataTypes/DateTime.hs b/src/lib/ProjectM36/DataTypes/DateTime.hs --- a/src/lib/ProjectM36/DataTypes/DateTime.hs +++ b/src/lib/ProjectM36/DataTypes/DateTime.hs @@ -8,7 +8,7 @@ dateTimeAtomFunctions = HS.fromList [ AtomFunction { atomFuncName = "dateTimeFromEpochSeconds", atomFuncType = [IntAtomType, DateTimeAtomType], - atomFuncBody = compiledAtomFunctionBody $ \((IntAtom epoch):_) -> pure (DateTimeAtom (posixSecondsToUTCTime (realToFrac epoch))) + atomFuncBody = compiledAtomFunctionBody $ \(IntAtom epoch:_) -> pure (DateTimeAtom (posixSecondsToUTCTime (realToFrac epoch))) }] diff --git a/src/lib/ProjectM36/DataTypes/Day.hs b/src/lib/ProjectM36/DataTypes/Day.hs --- a/src/lib/ProjectM36/DataTypes/Day.hs +++ b/src/lib/ProjectM36/DataTypes/Day.hs @@ -8,11 +8,11 @@ dayAtomFunctions = HS.fromList [ AtomFunction { atomFuncName = "fromGregorian", atomFuncType = [IntAtomType, IntAtomType, IntAtomType, DayAtomType], - atomFuncBody = compiledAtomFunctionBody $ \((IntAtom year):(IntAtom month):(IntAtom day):_) -> pure $ DayAtom (fromGregorian (fromIntegral year) month day) + atomFuncBody = compiledAtomFunctionBody $ \(IntAtom year:IntAtom month:IntAtom day:_) -> pure $ DayAtom (fromGregorian (fromIntegral year) month day) }, AtomFunction { atomFuncName = "dayEarlierThan", atomFuncType = [DayAtomType, DayAtomType, BoolAtomType], - atomFuncBody = compiledAtomFunctionBody $ \((ConstructedAtom _ _ (IntAtom dayA:_)):(ConstructedAtom _ _ (IntAtom dayB:_)):_) -> pure (BoolAtom (dayA < dayB)) + atomFuncBody = compiledAtomFunctionBody $ \(ConstructedAtom _ _ (IntAtom dayA:_):ConstructedAtom _ _ (IntAtom dayB:_):_) -> pure (BoolAtom (dayA < dayB)) } ] diff --git a/src/lib/ProjectM36/DataTypes/Either.hs b/src/lib/ProjectM36/DataTypes/Either.hs --- a/src/lib/ProjectM36/DataTypes/Either.hs +++ b/src/lib/ProjectM36/DataTypes/Either.hs @@ -14,5 +14,5 @@ eitherAtomFunctions :: AtomFunctions eitherAtomFunctions = HS.fromList [ - compiledAtomFunction "isLeft" [eitherAtomType (TypeVariableType "a") (TypeVariableType "b"), BoolAtomType] $ \((ConstructedAtom dConsName _ _):_) -> pure (BoolAtom (dConsName == "Left")) + compiledAtomFunction "isLeft" [eitherAtomType (TypeVariableType "a") (TypeVariableType "b"), BoolAtomType] $ \(ConstructedAtom dConsName _ _:_) -> pure (BoolAtom (dConsName == "Left")) ] diff --git a/src/lib/ProjectM36/DataTypes/Interval.hs b/src/lib/ProjectM36/DataTypes/Interval.hs new file mode 100644 --- /dev/null +++ b/src/lib/ProjectM36/DataTypes/Interval.hs @@ -0,0 +1,105 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module ProjectM36.DataTypes.Interval where +import ProjectM36.AtomFunctionBody +import ProjectM36.Base +import ProjectM36.AtomType +import ProjectM36.DataTypes.Primitive +import ProjectM36.AtomFunctionError +import qualified Data.HashSet as HS + +-- in lieu of typeclass support, we just hard-code the types which can be part of an interval +supportsInterval :: AtomType -> Bool +supportsInterval typ = case typ of + IntAtomType -> True + DoubleAtomType -> True + TextAtomType -> False -- just because it supports ordering, doesn't mean it makes sense in an interval + DayAtomType -> True + DateTimeAtomType -> True + ByteStringAtomType -> False + BoolAtomType -> False + IntervalAtomType _ -> False + RelationAtomType _ -> False + ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this + TypeVariableType _ -> False + +supportsOrdering :: AtomType -> Bool +supportsOrdering typ = case typ of + IntAtomType -> True + DoubleAtomType -> True + TextAtomType -> True + DayAtomType -> True + DateTimeAtomType -> True + ByteStringAtomType -> False + BoolAtomType -> False + IntervalAtomType _ -> False + RelationAtomType _ -> False + ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this + TypeVariableType _ -> False + +atomCompare :: Atom -> Atom -> Either AtomFunctionError Ordering +atomCompare a1 a2 = let aType = atomTypeForAtom a1 + go a b = Right (compare a b) + typError = Left (AtomTypeDoesNotSupportOrdering (prettyAtomType aType)) in + if atomTypeForAtom a1 /= atomTypeForAtom a2 then + Left AtomFunctionTypeMismatchError + else if not (supportsOrdering aType) then + typError + else + case (a1, a2) of + (IntAtom a, IntAtom b) -> go a b + (DoubleAtom a, DoubleAtom b) -> go a b + (TextAtom a, TextAtom b) -> go a b + (DayAtom a, DayAtom b) -> go a b + (DateTimeAtom a, DateTimeAtom b) -> go a b + _ -> typError + +--check that interval is properly ordered and that the boundaries make sense +createInterval :: Atom -> Atom -> OpenInterval -> OpenInterval -> Either AtomFunctionError Atom +createInterval atom1 atom2 bopen eopen = do + cmp <- atomCompare atom1 atom2 + case cmp of + GT -> Left InvalidIntervalOrdering + EQ -> if bopen || eopen then + Left InvalidIntervalBoundaries + else + Right valid + LT -> Right valid + where valid = IntervalAtom atom1 atom2 bopen eopen + +intervalAtomFunctions :: AtomFunctions +intervalAtomFunctions = HS.fromList [ + AtomFunction { atomFuncName = "interval", + atomFuncType = [TypeVariableType "a", + TypeVariableType "a", + BoolAtomType, + BoolAtomType, + IntervalAtomType (TypeVariableType "a")], + atomFuncBody = compiledAtomFunctionBody $ \(atom1:atom2:BoolAtom bopen:BoolAtom eopen:_) -> do + let aType = atomTypeForAtom atom1 + if supportsInterval aType then + createInterval atom1 atom2 bopen eopen + else + Left (AtomTypeDoesNotSupportInterval (prettyAtomType aType)) + }, + AtomFunction { + atomFuncName = "interval_overlaps", + atomFuncType = [IntervalAtomType (TypeVariableType "a"), + IntervalAtomType (TypeVariableType "a"), + BoolAtomType], + atomFuncBody = compiledAtomFunctionBody $ \(i1@IntervalAtom{}:i2@IntervalAtom{}:_) -> do + res <- intervalOverlaps i1 i2 + pure (BoolAtom res) + }] + + +intervalOverlaps :: Atom -> Atom -> Either AtomFunctionError Bool +intervalOverlaps (IntervalAtom i1start i1end i1startopen i1endopen) (IntervalAtom i2start i2end i2startopen i2endopen) = do + cmp1 <- atomCompare i1start i2end + cmp2 <- atomCompare i2start i1end + let startcmp = if i1startopen || i2endopen then oplt else oplte + endcmp = if i2startopen || i1endopen then oplt else oplte + oplte op = op == LT || op == EQ + oplt op = op == LT + pure (startcmp cmp1 && endcmp cmp2) +intervalOverlaps _ _ = Left AtomFunctionTypeMismatchError + diff --git a/src/lib/ProjectM36/DataTypes/List.hs b/src/lib/ProjectM36/DataTypes/List.hs --- a/src/lib/ProjectM36/DataTypes/List.hs +++ b/src/lib/ProjectM36/DataTypes/List.hs @@ -26,7 +26,7 @@ listMaybeHead (ConstructedAtom "Cons" _ (val:_)) = pure (ConstructedAtom "Just" aType [val]) where aType = maybeAtomType (atomTypeForAtom val) -listMaybeHead (ConstructedAtom "Empty" (ConstructedAtomType _ tvMap) _) = do +listMaybeHead (ConstructedAtom "Empty" (ConstructedAtomType _ tvMap) _) = case M.lookup "a" tvMap of Nothing -> Left AtomFunctionTypeMismatchError Just aType -> pure (ConstructedAtom "Nothing" aType []) diff --git a/src/lib/ProjectM36/DataTypes/Maybe.hs b/src/lib/ProjectM36/DataTypes/Maybe.hs --- a/src/lib/ProjectM36/DataTypes/Maybe.hs +++ b/src/lib/ProjectM36/DataTypes/Maybe.hs @@ -19,12 +19,12 @@ AtomFunction { atomFuncName ="isJust", atomFuncType = [maybeAtomType (TypeVariableType "a"), BoolAtomType], - atomFuncBody = AtomFunctionBody Nothing $ \((ConstructedAtom dConsName _ _):_) -> pure $ BoolAtom (dConsName /= "Nothing") + atomFuncBody = AtomFunctionBody Nothing $ \(ConstructedAtom dConsName _ _:_) -> pure $ BoolAtom (dConsName /= "Nothing") }, AtomFunction { atomFuncName = "fromMaybe", atomFuncType = [TypeVariableType "a", maybeAtomType (TypeVariableType "a"), TypeVariableType "a"], - atomFuncBody = AtomFunctionBody Nothing $ \(defaultAtom:(ConstructedAtom dConsName _ (atomVal:_)):_) -> if atomTypeForAtom defaultAtom /= atomTypeForAtom atomVal then Left AtomFunctionTypeMismatchError else if dConsName == "Nothing" then pure defaultAtom else pure atomVal + atomFuncBody = AtomFunctionBody Nothing $ \(defaultAtom:ConstructedAtom dConsName _ (atomVal:_):_) -> if atomTypeForAtom defaultAtom /= atomTypeForAtom atomVal then Left AtomFunctionTypeMismatchError else if dConsName == "Nothing" then pure defaultAtom else pure atomVal } ] diff --git a/src/lib/ProjectM36/DataTypes/Primitive.hs b/src/lib/ProjectM36/DataTypes/Primitive.hs --- a/src/lib/ProjectM36/DataTypes/Primitive.hs +++ b/src/lib/ProjectM36/DataTypes/Primitive.hs @@ -33,5 +33,6 @@ atomTypeForAtom (DateTimeAtom _) = DateTimeAtomType atomTypeForAtom (ByteStringAtom _) = ByteStringAtomType atomTypeForAtom (BoolAtom _) = BoolAtomType +atomTypeForAtom (IntervalAtom a _ _ _) = IntervalAtomType (atomTypeForAtom a) atomTypeForAtom (RelationAtom (Relation attrs _)) = RelationAtomType attrs atomTypeForAtom (ConstructedAtom _ aType _) = aType diff --git a/src/lib/ProjectM36/DatabaseContext.hs b/src/lib/ProjectM36/DatabaseContext.hs --- a/src/lib/ProjectM36/DatabaseContext.hs +++ b/src/lib/ProjectM36/DatabaseContext.hs @@ -21,7 +21,7 @@ where relVarsExprs = map (\(name, rel) -> Assign name (ExistingRelation rel)) (M.toList (relationVariables context)) incDepsExprs :: [DatabaseContextExpr] - incDepsExprs = map (\(name, dep) -> AddInclusionDependency name dep) (M.toList (inclusionDependencies context)) + incDepsExprs = map (uncurry AddInclusionDependency) (M.toList (inclusionDependencies context)) funcsExprs = [] -- map (\func -> ) (HS.toList funcs) -- there are no databaseExprs to add atom functions yet basicDatabaseContext :: DatabaseContext diff --git a/src/lib/ProjectM36/DatabaseContextFunction.hs b/src/lib/ProjectM36/DatabaseContextFunction.hs --- a/src/lib/ProjectM36/DatabaseContextFunction.hs +++ b/src/lib/ProjectM36/DatabaseContextFunction.hs @@ -49,8 +49,8 @@ databaseContextFunctionReturnType :: TypeConstructor -> TypeConstructor databaseContextFunctionReturnType tCons = ADTypeConstructor "Either" [ - (ADTypeConstructor "DatabaseContextFunctionError" []), + ADTypeConstructor "DatabaseContextFunctionError" [], tCons] createScriptedDatabaseContextFunction :: DatabaseContextFunctionName -> [TypeConstructor] -> TypeConstructor -> DatabaseContextFunctionBodyScript -> DatabaseContextIOExpr -createScriptedDatabaseContextFunction funcName argsIn retArg script = AddDatabaseContextFunction funcName (argsIn ++ [databaseContextFunctionReturnType retArg]) script +createScriptedDatabaseContextFunction funcName argsIn retArg = AddDatabaseContextFunction funcName (argsIn ++ [databaseContextFunctionReturnType retArg]) diff --git a/src/lib/ProjectM36/DatabaseContextFunctionError.hs b/src/lib/ProjectM36/DatabaseContextFunctionError.hs --- a/src/lib/ProjectM36/DatabaseContextFunctionError.hs +++ b/src/lib/ProjectM36/DatabaseContextFunctionError.hs @@ -4,5 +4,6 @@ import Data.Binary import Control.DeepSeq +{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} data DatabaseContextFunctionError = DatabaseContextFunctionUserError String deriving (Generic, Eq, Show, Binary, NFData) diff --git a/src/lib/ProjectM36/DatabaseContextFunctionUtils.hs b/src/lib/ProjectM36/DatabaseContextFunctionUtils.hs new file mode 100644 --- /dev/null +++ b/src/lib/ProjectM36/DatabaseContextFunctionUtils.hs @@ -0,0 +1,15 @@ +module ProjectM36.DatabaseContextFunctionUtils where +import ProjectM36.RelationalExpression +import ProjectM36.Base +import ProjectM36.DatabaseContextFunctionError +import ProjectM36.Error +import Control.Monad.State +import Control.Monad.Trans.Reader + +executeDatabaseContextExpr :: DatabaseContextExpr -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext +executeDatabaseContextExpr expr context = case runState (evalDatabaseContextExpr expr) (freshDatabaseState context) of + (Nothing, (context', _, _)) -> pure context' + (Just err, _) -> error (show err) + +executeRelationalExpr :: RelationalExpr -> DatabaseContext -> Either RelationalError Relation +executeRelationalExpr expr context = runReader (evalRelationalExpr expr) (mkRelationalExprState context) diff --git a/src/lib/ProjectM36/Error.hs b/src/lib/ProjectM36/Error.hs --- a/src/lib/ProjectM36/Error.hs +++ b/src/lib/ProjectM36/Error.hs @@ -33,6 +33,7 @@ | RootTransactionTraversalError | HeadNameSwitchingHeadProhibitedError HeadName | NoSuchHeadNameError HeadName + | UnknownHeadError | NewTransactionMayNotHaveChildrenError TransactionId | ParentCountTraversalError Int Int --maximum, requested | NewTransactionMissingParentError TransactionId @@ -95,7 +96,8 @@ deriving (Show,Eq,Generic,Binary,Typeable, NFData) data PersistenceError = InvalidDirectoryError FilePath | - MissingTransactionError TransactionId + MissingTransactionError TransactionId | + WrongDatabaseFormatVersionError String String deriving (Show, Eq, Generic, Binary, NFData) --collapse list of errors into normal error- if there is just one, just return one @@ -122,7 +124,7 @@ SyntaxErrorCompilationError String | ScriptCompilationDisabledError | OtherScriptCompilationError String - deriving (Show,Eq, Generic, Binary, Typeable, NFData) + deriving (Show, Eq, Generic, Binary, Typeable, NFData) instance Exception ScriptCompilationError diff --git a/src/lib/ProjectM36/InclusionDependency.hs b/src/lib/ProjectM36/InclusionDependency.hs --- a/src/lib/ProjectM36/InclusionDependency.hs +++ b/src/lib/ProjectM36/InclusionDependency.hs @@ -7,14 +7,14 @@ import qualified Data.Text as T inclusionDependenciesAsRelation :: InclusionDependencies -> Either RelationalError Relation -inclusionDependenciesAsRelation incDeps = do +inclusionDependenciesAsRelation incDeps = mkRelationFromList attrs (map incDepAsAtoms (M.toList incDeps)) where attrs = attributesFromList [Attribute "name" TextAtomType, Attribute "sub" TextAtomType, Attribute "super" TextAtomType ] - incDepAsAtoms (name, (InclusionDependency exprA exprB)) = [TextAtom name, + incDepAsAtoms (name, InclusionDependency exprA exprB) = [TextAtom name, TextAtom (T.pack (show exprA)), TextAtom (T.pack (show exprB))] diff --git a/src/lib/ProjectM36/IsomorphicSchema.hs b/src/lib/ProjectM36/IsomorphicSchema.hs --- a/src/lib/ProjectM36/IsomorphicSchema.hs +++ b/src/lib/ProjectM36/IsomorphicSchema.hs @@ -39,21 +39,16 @@ -- A schema is fully isomorphic iff all relvars in the base context are in the "out" relvars, but only once. --TODO: add relvar must appear exactly once constraint validateSchema :: Schema -> DatabaseContext -> Maybe SchemaError -validateSchema potentialSchema baseContext = do - if not (S.null rvDiff) then - Just (RelVarReferencesMissing rvDiff) - else if not (null outDupes) then - Just (RelVarOutReferencedMoreThanOnce (head outDupes)) - else if not (null inDupes) then - Just (RelVarInReferencedMoreThanOnce (head inDupes)) - else - Nothing +validateSchema potentialSchema baseContext | not (S.null rvDiff) = Just (RelVarReferencesMissing rvDiff) + | not (null outDupes) = Just (RelVarOutReferencedMoreThanOnce (head outDupes)) + | not (null inDupes) = Just (RelVarInReferencedMoreThanOnce (head inDupes)) + | otherwise = Nothing where --check that the predicate for IsoUnion and IsoRestrict holds right now outDupes = duplicateNames (namesList isomorphOutRelVarNames) inDupes = duplicateNames (namesList isomorphInRelVarNames) duplicateNames = dupes . L.sort - namesList isoFunc = concat (map isoFunc (isomorphs potentialSchema)) + namesList isoFunc = concatMap isoFunc (isomorphs potentialSchema) expectedRelVars = M.keysSet (relationVariables baseContext) schemaRelVars = isomorphsOutRelVarNames (isomorphs potentialSchema) rvDiff = S.difference expectedRelVars schemaRelVars @@ -116,15 +111,15 @@ processDatabaseContextExprSchemaUpdate schema@(Schema morphs) expr = case expr of Define rv _ | S.notMember rv validSchemaName -> passthru rv Assign rv _ | S.notMember rv validSchemaName -> passthru rv - Undefine rv | S.member rv validSchemaName -> Schema (filter (\morph -> elem rv (isomorphInRelVarNames morph)) morphs) - MultipleExpr exprs -> foldr (\expr' schema' -> processDatabaseContextExprSchemaUpdate schema' expr') schema exprs + Undefine rv | S.member rv validSchemaName -> Schema (filter (elem rv . isomorphInRelVarNames) morphs) + MultipleExpr exprs -> foldr (flip processDatabaseContextExprSchemaUpdate) schema exprs _ -> schema where validSchemaName = isomorphsInRelVarNames morphs passthru rvname = Schema (morphs ++ [IsoRename rvname rvname]) processDatabaseContextExprSchemasUpdate :: Subschemas -> DatabaseContextExpr -> Subschemas -processDatabaseContextExprSchemasUpdate subschemas expr = M.map (\schema -> processDatabaseContextExprSchemaUpdate schema expr) subschemas +processDatabaseContextExprSchemasUpdate subschemas expr = M.map (`processDatabaseContextExprSchemaUpdate` expr) subschemas -- re-evaluate- it's not possible to display an incdep that may be for a foreign key to a relvar which is not available in the subschema! -- weird compromise: allow inclusion dependencies failures not in the subschema to be propagated- in the worst case, only the inclusion dependency's name is leaked. @@ -318,7 +313,7 @@ -- in the case of IsoRestrict, the database context should be updated with the restriction so that if the restriction does not hold, then the schema cannot be created evalSchemaExpr :: SchemaExpr -> DatabaseContext -> Subschemas -> Either RelationalError (Subschemas, DatabaseContext) -evalSchemaExpr (AddSubschema sname morphs) context sschemas = do +evalSchemaExpr (AddSubschema sname morphs) context sschemas = if M.member sname sschemas then Left (SubschemaNameInUseError sname) else case valid of diff --git a/src/lib/ProjectM36/Key.hs b/src/lib/ProjectM36/Key.hs --- a/src/lib/ProjectM36/Key.hs +++ b/src/lib/ProjectM36/Key.hs @@ -27,10 +27,10 @@ inclusionDependencyForKey attrNames relExpr = --InclusionDependency name (exprCount relExpr) (exprCount (projectedOnKeys relExpr)) InclusionDependency equalityExpr (ExistingRelation relationFalse) where - projectedOnKeys expr = Project attrNames expr + projectedOnKeys = Project attrNames exprAsSubRelation expr = Extend (AttributeExtendTupleExpr "a" (RelationAtomExpr expr)) (ExistingRelation relationTrue) exprCount expr = projectionForCount (Extend (AttributeExtendTupleExpr "b" (FunctionAtomExpr "count" [AttributeAtomExpr "a"] () )) (exprAsSubRelation expr)) - projectionForCount expr = Project (AttributeNames $ S.fromList ["b"]) expr + projectionForCount = Project (AttributeNames $ S.fromList ["b"]) equalityExpr = NotEquals (exprCount relExpr) (exprCount (projectedOnKeys relExpr)) -- | Create a 'DatabaseContextExpr' which can be used to add a uniqueness constraint to attributes on one relation variable. @@ -39,6 +39,16 @@ -- | Create a foreign key constraint from the first relation variable and attributes to the second. databaseContextExprForForeignKey :: IncDepName -> (RelVarName, [AttributeName]) -> (RelVarName, [AttributeName]) -> DatabaseContextExpr -databaseContextExprForForeignKey fkName (rvA, attrsA) (rvB, attrsB) = AddInclusionDependency fkName $ InclusionDependency (Project (attrsL attrsA) (RelationVariable rvA ())) (Project (attrsL attrsB) (RelationVariable rvB ())) +databaseContextExprForForeignKey fkName (rvA, attrsA) (rvB, attrsB) = + AddInclusionDependency fkName (InclusionDependency + (renameIfNecessary attrsB attrsA (Project (attrsL attrsA) + (RelationVariable rvA ()))) + (Project (attrsL attrsB) + (RelationVariable rvB ()))) where attrsL = AttributeNames . S.fromList + renameIfNecessary attrsExpected attrsExisting expr = foldr folder expr (zip attrsExpected attrsExisting) + folder (attrExpected, attrExisting) expr = if attrExpected == attrExisting then + expr + else + Rename attrExisting attrExpected expr diff --git a/src/lib/ProjectM36/MiscUtils.hs b/src/lib/ProjectM36/MiscUtils.hs --- a/src/lib/ProjectM36/MiscUtils.hs +++ b/src/lib/ProjectM36/MiscUtils.hs @@ -3,7 +3,7 @@ --returns duplicates of a pre-sorted list dupes :: Eq a => [a] -> [a] dupes [] = [] -dupes (_:[]) = [] -dupes (x:y:[]) = if x == y then [x] else [] +dupes [_] = [] +dupes [x,y] = [x | x == y] dupes (x:y:xs) = dupes(x:[y]) ++ dupes(y : xs) diff --git a/src/lib/ProjectM36/Persist.hs b/src/lib/ProjectM36/Persist.hs --- a/src/lib/ProjectM36/Persist.hs +++ b/src/lib/ProjectM36/Persist.hs @@ -44,8 +44,9 @@ syncDirectory sync dstPath -- System.Directory's renameFile/renameDirectory almost do exactly what we want except that it needlessly differentiates between directories and files +{-# ANN atomicRename ("HLint: ignore Eta reduce" :: String) #-} atomicRename :: FilePath -> FilePath -> IO () -atomicRename srcPath dstPath = do +atomicRename srcPath dstPath = #if defined(mingw32_HOST_OS) Win32.moveFileEx srcPath dstPath Win32.mOVEFILE_REPLACE_EXISTING #else @@ -53,7 +54,7 @@ #endif syncHandle :: DiskSync -> Handle -> IO () -syncHandle FsyncDiskSync handle = do +syncHandle FsyncDiskSync handle = #if defined(mingw32_HOST_OS) withHandleToHANDLE handle (\h -> Win32.flushFileBuffers h) #elif defined(linux_HOST_OS) @@ -69,7 +70,7 @@ syncDirectory NoDiskSync _ = pure () writeBSFileSync :: DiskSync -> FilePath -> BS.ByteString -> IO () -writeBSFileSync sync path bstring = do +writeBSFileSync sync path bstring = withFile path WriteMode $ \handle -> do BS.hPut handle bstring syncHandle sync handle diff --git a/src/lib/ProjectM36/Relation.hs b/src/lib/ProjectM36/Relation.hs --- a/src/lib/ProjectM36/Relation.hs +++ b/src/lib/ProjectM36/Relation.hs @@ -12,7 +12,7 @@ import qualified ProjectM36.AttributeNames as AS import ProjectM36.TupleSet import ProjectM36.Error -import qualified Control.Parallel.Strategies as P +--import qualified Control.Parallel.Strategies as P import qualified ProjectM36.TypeConstructorDef as TCD import qualified ProjectM36.DataConstructorDef as DCD import qualified Data.Text as T @@ -44,7 +44,7 @@ emptyRelationWithAttrs attrs = Relation attrs emptyTupleSet mkRelation :: Attributes -> RelationTupleSet -> Either RelationalError Relation -mkRelation attrs tupleSet = do +mkRelation attrs tupleSet = --check that all tuples have the same keys --check that all tuples have keys (1-N) where N is the attribute count case verifyTupleSet attrs tupleSet of @@ -85,7 +85,7 @@ else Right $ Relation attrs1 newtuples where - newtuples = RelationTupleSet $ HS.toList . HS.fromList $ (asList tupSet1) ++ (map (reorderTuple attrs1) (asList tupSet2)) + newtuples = RelationTupleSet $ HS.toList . HS.fromList $ asList tupSet1 ++ map (reorderTuple attrs1) (asList tupSet2) project :: AttributeNames -> Relation -> Either RelationalError Relation project projectionAttrNames rel = @@ -95,22 +95,19 @@ where folder newAttrs tupleToProject acc = case acc of Left err -> Left err - Right acc2 -> union acc2 (Relation newAttrs (RelationTupleSet [tupleProject (A.attributeNameSet newAttrs) tupleToProject])) + Right acc2 -> acc2 `union` Relation newAttrs (RelationTupleSet [tupleProject (A.attributeNameSet newAttrs) tupleToProject]) rename :: AttributeName -> AttributeName -> Relation -> Either RelationalError Relation -rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet) = - if not attributeValid - then Left $ AttributeNamesMismatchError (S.singleton oldAttrName) - else if newAttributeInUse - then Left $ AttributeNameInUseError newAttrName - else - mkRelation newAttrs newTupSet +rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet) + | not attributeValid = Left $ AttributeNamesMismatchError (S.singleton oldAttrName) + | newAttributeInUse = Left $ AttributeNameInUseError newAttrName + | otherwise = mkRelation newAttrs newTupSet where newAttributeInUse = A.attributeNamesContained (S.singleton newAttrName) (attributeNames rel) attributeValid = A.attributeNamesContained (S.singleton oldAttrName) (attributeNames rel) newAttrs = A.renameAttributes oldAttrName newAttrName oldAttrs newTupSet = RelationTupleSet $ map tupsetmapper (asList oldTupSet) - tupsetmapper tuple = tupleRenameAttribute oldAttrName newAttrName tuple + tupsetmapper = tupleRenameAttribute oldAttrName newAttrName --the algebra should return a relation of one attribute and one row with the arity arity :: Relation -> Int @@ -163,10 +160,10 @@ --help restriction function --returns a subrelation of restrictEq :: RelationTuple -> Relation -> Either RelationalError Relation -restrictEq tuple rel = restrict rfilter rel +restrictEq tuple = restrict rfilter where - rfilter :: RelationTuple -> Bool - rfilter tupleIn = tupleIntersection tuple tupleIn == tuple + rfilter :: RelationTuple -> Either RelationalError Bool + rfilter tupleIn = pure (tupleIntersection tuple tupleIn == tuple) -- unwrap relation-valued attribute -- return error if relval attrs and nongroup attrs overlap @@ -182,7 +179,7 @@ Left err -> Left err Right accRel -> do ungrouped <- tupleUngroup relvalAttrName newAttrs tupleIn - union accRel ungrouped + accRel `union` ungrouped --take an relval attribute name and a tuple and ungroup the relval tupleUngroup :: AttributeName -> Attributes -> RelationTuple -> Either RelationalError Relation @@ -203,11 +200,11 @@ (RelationAtomType relAttrs) -> Right relAttrs _ -> Left $ AttributeIsNotRelationValuedError relvalAttrName -restrict :: (RelationTuple -> Bool) -> Relation -> Either RelationalError Relation ---restrict rfilter (Relation attrs tupset) = Right $ Relation attrs $ HS.filter rfilter tupset -restrict rfilter (Relation attrs tupset) = Right $ Relation attrs processedTupSet - where - processedTupSet = RelationTupleSet ((filter rfilter (asList tupset)) `P.using` (P.parListChunk 1000 P.rdeepseq)) +type RestrictionFilter = RelationTuple -> Either RelationalError Bool +restrict :: RestrictionFilter -> Relation -> Either RelationalError Relation +restrict rfilter (Relation attrs tupset) = do + tuples <- filterM rfilter (asList tupset) + Right $ Relation attrs (RelationTupleSet tuples) --joins on columns with the same name- use rename to avoid this- base case: cartesian product --after changing from string atoms, there needs to be a type-checking step! @@ -233,11 +230,11 @@ where attrsA = attributes relA attrsB = attributes relB - rfilter tupInA = relFold (\tupInB acc -> if acc == False then False else if tupInB == tupInA then False else True) True relB + rfilter tupInA = relFold (\tupInB acc -> if acc == Right False then pure False else pure (tupInB /= tupInA)) (Right True) relB --a map should NOT change the structure of a relation, so attributes should be constant relMap :: (RelationTuple -> Either RelationalError RelationTuple) -> Relation -> Either RelationalError Relation -relMap mapper (Relation attrs tupleSet) = do +relMap mapper (Relation attrs tupleSet) = case forM (asList tupleSet) typeMapCheck of Right remappedTupleSet -> mkRelation attrs (RelationTupleSet remappedTupleSet) Left err -> Left err @@ -256,6 +253,13 @@ relFold :: (RelationTuple -> a -> a) -> a -> Relation -> a relFold folder acc (Relation _ tupleSet) = foldr folder acc (asList tupleSet) +-- | Generate a randomly-ordered list of tuples from the relation. +toList :: Relation -> IO [RelationTuple] +toList rel = do + gen <- newStdGen + let rel' = evalRand (randomizeTupleOrder rel) gen + pure (relFold (:) [] rel') + --image relation as defined by CJ Date --given tupleA and relationB, return restricted relation where tuple attributes are not the attribues in tupleA but are attributes in relationB and match the tuple's value @@ -291,7 +295,7 @@ mkTypeConsDescription (tCons, dConsList) = RelationTuple attrs (V.fromList [TextAtom (TCD.name tCons), mkDataConsRelation dConsList]) - mkDataConsRelation dConsList = case mkRelationFromTuples subAttrs $ map (\dCons -> RelationTuple subAttrs (V.singleton $ TextAtom $ T.intercalate " " ((DCD.name dCons):(map (T.pack . show) (DCD.fields dCons))))) dConsList of + mkDataConsRelation dConsList = case mkRelationFromTuples subAttrs $ map (\dCons -> RelationTuple subAttrs (V.singleton $ TextAtom $ T.intercalate " " (DCD.name dCons:map (T.pack . show) (DCD.fields dCons)))) dConsList of Left err -> error ("mkRelationFromTuples pooped " ++ show err) Right rel -> RelationAtom rel diff --git a/src/lib/ProjectM36/Relation/Parse/CSV.hs b/src/lib/ProjectM36/Relation/Parse/CSV.hs --- a/src/lib/ProjectM36/Relation/Parse/CSV.hs +++ b/src/lib/ProjectM36/Relation/Parse/CSV.hs @@ -15,6 +15,7 @@ import qualified Data.Text as T import Data.Attoparsec.ByteString.Lazy import ProjectM36.Atom +import Control.Arrow data CsvImportError = CsvParseError String | AttributeMappingError RelationalError | @@ -27,7 +28,7 @@ --special case from Text- outer quotes are *not* required in CSV, so we have to add them to make it parseable makeAtomFromCSVText :: AttributeName -> AtomType -> T.Text -> Either RelationalError Atom makeAtomFromCSVText attrName aType textIn = makeAtomFromText attrName aType $ if aType == TextAtomType then - ("\"" `T.append` textIn `T.append` "\"") + "\"" `T.append` textIn `T.append` "\"" else textIn @@ -37,17 +38,17 @@ Done _ (headerRaw,vecMapsRaw) -> do let strHeader = V.map decodeUtf8 headerRaw strMapRecords = V.map convertMap vecMapsRaw - convertMap hmap = HM.fromList $ L.map (\(k,v) -> (decodeUtf8 k, (T.unpack . decodeUtf8) v)) (HM.toList hmap) + convertMap hmap = HM.fromList $ L.map (decodeUtf8 *** (T.unpack . decodeUtf8)) (HM.toList hmap) attrNames = V.map A.attributeName attrs attrNameSet = S.fromList (V.toList attrNames) headerSet = S.fromList (V.toList strHeader) makeTupleList :: HM.HashMap AttributeName String -> [Either CsvImportError Atom] - makeTupleList tupMap = V.toList $ V.map (\attr -> either (Left . AttributeMappingError) Right $ makeAtomFromCSVText (A.attributeName attr) (A.atomType attr) (T.pack $ tupMap HM.! (A.attributeName attr))) attrs - case attrNameSet == headerSet of - False -> Left $ HeaderAttributeMismatchError (S.difference attrNameSet headerSet) - True -> do - tupleList <- mapM sequence $ V.toList (V.map makeTupleList strMapRecords) - case mkRelationFromList attrs tupleList of - Left err -> Left (AttributeMappingError err) - Right rel -> Right rel + makeTupleList tupMap = V.toList $ V.map (\attr -> either (Left . AttributeMappingError) Right $ makeAtomFromCSVText (A.attributeName attr) (A.atomType attr) (T.pack $ tupMap HM.! A.attributeName attr)) attrs + if attrNameSet == headerSet then do + tupleList <- mapM sequence $ V.toList (V.map makeTupleList strMapRecords) + case mkRelationFromList attrs tupleList of + Left err -> Left (AttributeMappingError err) + Right rel -> Right rel + else + Left $ HeaderAttributeMismatchError (S.difference attrNameSet headerSet) diff --git a/src/lib/ProjectM36/Relation/Show/CSV.hs b/src/lib/ProjectM36/Relation/Show/CSV.hs --- a/src/lib/ProjectM36/Relation/Show/CSV.hs +++ b/src/lib/ProjectM36/Relation/Show/CSV.hs @@ -13,12 +13,15 @@ --spit out error for relations without attributes (since relTrue and relFalse cannot be distinguished then as CSV) and for relations with relation-valued attributes relationAsCSV :: Relation -> Either RelationalError BS.ByteString -relationAsCSV (Relation attrs tupleSet) = if relValAttrs /= [] then --check for relvalued attributes - Left $ RelationValuedAttributesNotSupportedError (map attributeName relValAttrs) - else if V.length attrs == 0 then --check that there is at least one attribute - Left $ TupleAttributeCountMismatchError 0 - else - Right $ encodeByName bsAttrNames $ map RecordRelationTuple (asList tupleSet) +relationAsCSV (Relation attrs tupleSet) + --check for relvalued attributes + | relValAttrs /= [] = + Left $ RelationValuedAttributesNotSupportedError (map attributeName relValAttrs) + --check that there is at least one attribute + | V.null attrs = + Left $ TupleAttributeCountMismatchError 0 + | otherwise = + Right $ encodeByName bsAttrNames $ map RecordRelationTuple (asList tupleSet) where relValAttrs = V.toList $ V.filter (isRelationAtomType . atomType) attrs bsAttrNames = V.map (TE.encodeUtf8 . attributeName) attrs @@ -31,7 +34,7 @@ newtype RecordRelationTuple = RecordRelationTuple {unTuple :: RelationTuple} instance ToNamedRecord RecordRelationTuple where - toNamedRecord rTuple = namedRecord $ map (\(k,v) -> TE.encodeUtf8 k .= (RecordAtom v)) (tupleAssocs $ unTuple rTuple) + toNamedRecord rTuple = namedRecord $ map (\(k,v) -> TE.encodeUtf8 k .= RecordAtom v) (tupleAssocs $ unTuple rTuple) instance DefaultOrdered RecordRelationTuple where headerOrder (RecordRelationTuple tuple) = V.map (TE.encodeUtf8 . attributeName) (tupleAttributes tuple) diff --git a/src/lib/ProjectM36/Relation/Show/Gnuplot.hs b/src/lib/ProjectM36/Relation/Show/Gnuplot.hs --- a/src/lib/ProjectM36/Relation/Show/Gnuplot.hs +++ b/src/lib/ProjectM36/Relation/Show/Gnuplot.hs @@ -24,13 +24,13 @@ --plotRelation :: Relation -> Either PlotError intFromAtomIndex :: Int -> RelationTuple -> Int -intFromAtomIndex index tup = (\i -> castInt i) $ (tupleAtoms tup) V.! index +intFromAtomIndex index tup = castInt $ tupleAtoms tup V.! index graph1DRelation :: Relation -> Plot2D.T Int Int graph1DRelation rel = Plot2D.list Graph2D.listPoints $ points1DRelation rel points1DRelation :: Relation -> [Int] -points1DRelation rel = relFold folder [] rel +points1DRelation = relFold folder [] where folder tup acc = intFromAtomIndex 0 tup : acc @@ -38,16 +38,16 @@ graph2DRelation rel = Plot2D.list Graph2D.points (points2DRelation rel) points2DRelation :: Relation -> [(Int, Int)] -points2DRelation rel = relFold folder [] rel +points2DRelation = relFold folder [] where folder tup acc = (intFromAtomIndex 0 tup, intFromAtomIndex 1 tup) : acc graph3DRelation :: Relation -> Plot3D.T Int Int Int -graph3DRelation rel = do +graph3DRelation rel = Plot3D.cloud Graph3D.points $ points3DRelation rel points3DRelation :: Relation -> [(Int, Int, Int)] -points3DRelation rel = relFold folder [] rel +points3DRelation = relFold folder [] where folder tup acc = (intFromAtomIndex 0 tup, intFromAtomIndex 1 tup, intFromAtomIndex 2 tup) : acc @@ -72,11 +72,11 @@ plotRelation rel = let attrTypes = V.replicate (arity rel) IntAtomType in if attrTypes /= A.atomTypes (attributes rel) then return $ Just InvalidAttributeTypeError - else do + else case arity rel of - 1 -> (GPA.plotDefault $ graph1DRelation rel) >> return Nothing - 2 -> (GPA.plotDefault $ graph2DRelation rel) >> return Nothing - 3 -> (GPA.plotDefault $ graph3DRelation rel) >> return Nothing + 1 -> GPA.plotDefault (graph1DRelation rel) >> return Nothing + 2 -> GPA.plotDefault (graph2DRelation rel) >> return Nothing + 3 -> GPA.plotDefault (graph3DRelation rel) >> return Nothing _ -> return $ Just InvalidAttributeCountError diff --git a/src/lib/ProjectM36/Relation/Show/HTML.hs b/src/lib/ProjectM36/Relation/Show/HTML.hs --- a/src/lib/ProjectM36/Relation/Show/HTML.hs +++ b/src/lib/ProjectM36/Relation/Show/HTML.hs @@ -10,15 +10,15 @@ import qualified Data.Text.IO as TIO attributesAsHTML :: Attributes -> Text -attributesAsHTML attrs = "" `append` (T.concat $ map oneAttrHTML attrNameList) `append` "" +attributesAsHTML attrs = "" `append` T.concat (map oneAttrHTML attrNameList) `append` "" where oneAttrHTML attrName = "" `append` attrName `append` "" attrNameList = sortedAttributeNameList (attributeNameSet attrs) relationAsHTML :: Relation -> Text -relationAsHTML rel@(Relation attrNameSet tupleSet) = "" `append` (attributesAsHTML attrNameSet) `append` (tupleSetAsHTML tupleSet) `append` "" `append` tablefooter `append` "
" +relationAsHTML rel@(Relation attrNameSet tupleSet) = "" `append` attributesAsHTML attrNameSet `append` tupleSetAsHTML tupleSet `append` "" `append` tablefooter `append` "
" where - tablefooter = "" `append` (pack $ show (cardinality rel)) `append` " tuples" + tablefooter = "" `append` pack (show (cardinality rel)) `append` " tuples" writeHTML :: Text -> IO () writeHTML = TIO.writeFile "/home/agentm/rel.html" diff --git a/src/lib/ProjectM36/Relation/Show/Term.hs b/src/lib/ProjectM36/Relation/Show/Term.hs --- a/src/lib/ProjectM36/Relation/Show/Term.hs +++ b/src/lib/ProjectM36/Relation/Show/Term.hs @@ -5,10 +5,11 @@ import ProjectM36.AtomType import ProjectM36.Tuple import ProjectM36.Relation -import ProjectM36.Attribute +import ProjectM36.Attribute hiding (null) import qualified Data.List as L import qualified Data.Text as T import qualified Data.Vector as V +import Control.Arrow hiding (left) boxV :: StringType boxV = "│" @@ -60,10 +61,10 @@ where cellSizeMatrix = cellSizes tab maxWidths = foldl mergeMax (baseSize (length header)) (map fst cellSizeMatrix) - baseSize num = take num (repeat 0) + baseSize num = replicate num 0 rowHeights = map snd cellSizeMatrix - maxHeights = map (\l -> if length l == 0 then 0 else L.maximumBy compare l) rowHeights - mergeMax a b = map (\(c,d) -> max c d) (zip a b) + maxHeights = map (\l -> if null l then 0 else L.maximum l) rowHeights + mergeMax = zipWith max --the normal "lines" function returns an empty list for an empty string which is not what we want breakLines :: StringType -> [StringType] @@ -71,14 +72,14 @@ breakLines x = T.lines x cellSizes :: Table -> [([Int], [Int])] -cellSizes (header, body) = map (\row -> (map maxRowWidth row, map (length . breakLines) row)) allRows +cellSizes (header, body) = map (map maxRowWidth &&& map (length . breakLines)) allRows where - maxRowWidth row = if length (lengths row) == 0 then + maxRowWidth row = if null (lengths row) then 0 else - L.maximumBy compare (lengths row) + L.maximum (lengths row) lengths row = map T.length (breakLines row) - allRows = [header] ++ body + allRows = header : body relationAsTable :: Relation -> Table relationAsTable rel@(Relation _ tupleSet) = (header, body) @@ -101,7 +102,7 @@ showAtom :: Int -> Atom -> StringType showAtom _ (RelationAtom rel) = renderTable $ relationAsTable rel -showAtom level (ConstructedAtom dConsName _ atoms) = showParens (level >= 1 && length atoms >= 1) $ T.concat (L.intersperse " " (dConsName : (map (showAtom 1) atoms))) +showAtom level (ConstructedAtom dConsName _ atoms) = showParens (level >= 1 && not (null atoms)) $ T.concat (L.intersperse " " (dConsName : map (showAtom 1) atoms)) showAtom _ atom = atomToText atom renderTable :: Table -> StringType @@ -112,13 +113,13 @@ renderHeader :: Table -> [Int] -> StringType renderHeader (header, body) columnLocations = renderTopBar `T.append` renderHeaderNames `T.append` renderBottomBar where - renderTopBar = boxTL `T.append` T.concat (L.intersperse boxTB (map (\x -> repeatString x boxH) columnLocations)) `T.append` boxTR `T.append` "\n" + renderTopBar = boxTL `T.append` T.concat (L.intersperse boxTB (map (`repeatString` boxH) columnLocations)) `T.append` boxTR `T.append` "\n" renderHeaderNames = renderRow header columnLocations 1 boxV - renderBottomBar = if length body == 0 then "" + renderBottomBar = if null body then "" else renderHBar boxLB boxC boxRB columnLocations `T.append` "\n" renderHBar :: StringType -> StringType -> StringType -> [Int] -> StringType -renderHBar left middle end columnLocations = left `T.append` T.concat (L.intersperse middle (map (\x -> repeatString x boxH) columnLocations)) `T.append` end +renderHBar left middle end columnLocations = left `T.append` T.concat (L.intersperse middle (map (`repeatString` boxH) columnLocations)) `T.append` end leftPaddedString :: Int -> Int -> StringType -> StringType leftPaddedString lineNum size str = if lineNum > length paddedLines -1 then @@ -131,7 +132,7 @@ renderRow :: [Cell] -> [Int] -> Int -> StringType -> StringType renderRow cells columnLocations rowHeight interspersed = T.unlines $ map renderOneLine [0..rowHeight-1] where - renderOneLine lineNum = boxV `T.append` T.concat (L.intersperse interspersed (map (\(size, value) -> leftPaddedString lineNum size value) (zip columnLocations cells))) `T.append` boxV + renderOneLine lineNum = boxV `T.append` T.concat (L.intersperse interspersed (zipWith (leftPaddedString lineNum) columnLocations cells)) `T.append` boxV renderBody :: [[Cell]] -> ([Int],[Int]) -> StringType renderBody cellMatrix cellLocs = renderRows `T.append` renderBottomBar @@ -149,7 +150,7 @@ orderedAttributeNames rel = map attributeName (orderedAttributes rel) repeatString :: Int -> StringType -> StringType -repeatString c s = T.concat (take c (repeat s)) +repeatString c s = T.concat (replicate c s) showRelation :: Relation -> StringType showRelation rel = renderTable (relationAsTable rel) diff --git a/src/lib/ProjectM36/RelationalExpression.hs b/src/lib/ProjectM36/RelationalExpression.hs --- a/src/lib/ProjectM36/RelationalExpression.hs +++ b/src/lib/ProjectM36/RelationalExpression.hs @@ -34,9 +34,7 @@ databaseContextExprDetailsFunc CountUpdatedTuples _ relIn = Relation attrs newTups where attrs = A.attributesFromList [Attribute "count" IntAtomType] - existingTuple = case singletonTuple relIn of - Just t -> t - Nothing -> error "impossible counting error in singletonTuple" + existingTuple = fromMaybe (error "impossible counting error in singletonTuple") (singletonTuple relIn) existingCount = case V.head (tupleAtoms existingTuple) of IntAtom v -> v _ -> error "impossible counting error in tupleAtoms" @@ -59,7 +57,7 @@ show (RelationalExprStateElems _) = "RelationalExprStateElems" mkRelationalExprState :: DatabaseContext -> RelationalExprStateElems -mkRelationalExprState ctx = RelationalExprStateElems ctx +mkRelationalExprState = RelationalExprStateElems mergeTuplesIntoRelationalExprState :: RelationTuple -> RelationalExprStateElems -> RelationalExprStateElems mergeTuplesIntoRelationalExprState tupIn (RelationalExprStateElems ctx) = RelationalExprStateTupleElems ctx tupIn @@ -84,7 +82,7 @@ type DatabaseState a = State DatabaseStateElems a -getStateContext :: DatabaseState (DatabaseContext) +getStateContext :: DatabaseState DatabaseContext getStateContext = do (ctx,_, _) <- get pure ctx @@ -109,7 +107,7 @@ --relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation) evalRelationalExpr (RelationVariable name _) = do - relvarTable <- liftM (relationVariables . stateElemsContext) ask + relvarTable <- fmap (relationVariables . stateElemsContext) ask return $ case M.lookup name relvarTable of Just res -> Right res Nothing -> Left $ RelVarNotDefinedError name @@ -147,24 +145,24 @@ Left err -> return $ Left err Right relB2 -> return $ difference relA2 relB2 -evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) = do +evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) = case mkRelation attributeSet tupleSet of Right rel -> return $ Right rel Left err -> return $ Left err evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do - currentContext <- liftM stateElemsContext ask + currentContext <- fmap stateElemsContext ask let tConss = typeConstructorMapping currentContext -- if the mAttrExprs is Nothing, then we should attempt to infer the tuple attributes from the first tuple itself- note that this is not always possible runExceptT $ do mAttrs <- case mAttrExprs of Just _ -> do - attrs <- mapM (\expr -> either throwE pure (evalAttrExpr tConss expr)) (fromMaybe [] mAttrExprs) + attrs <- mapM (either throwE pure . evalAttrExpr tConss) (fromMaybe [] mAttrExprs) pure (Just (A.attributesFromList attrs)) Nothing -> pure Nothing - tuples <- mapM (\expr -> liftE (evalTupleExpr mAttrs expr)) tupleExprs + tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs let attrs = fromMaybe firstTupleAttrs mAttrs - firstTupleAttrs = if length tuples == 0 then A.emptyAttributes else tupleAttributes (head tuples) + firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples) either throwE pure (mkRelation attrs (RelationTupleSet tuples)) evalRelationalExpr (ExistingRelation rel) = pure (Right rel) @@ -195,7 +193,8 @@ eFilterFunc <- predicateRestrictionFilter (attributes rel) predicateExpr case eFilterFunc of Left err -> return $ Left err - Right filterfunc -> return $ restrict filterfunc rel + Right filterfunc -> + pure (restrict filterfunc rel) evalRelationalExpr (Equals relExprA relExprB) = do evaldA <- evalRelationalExpr relExprA @@ -258,8 +257,8 @@ evalDatabaseContextExpr NoOperation = pure Nothing evalDatabaseContextExpr (Define relVarName attrExprs) = do - relvars <- liftM relationVariables getStateContext - tConss <- liftM typeConstructorMapping getStateContext + relvars <- fmap relationVariables getStateContext + tConss <- fmap typeConstructorMapping getStateContext let eAttrs = map (evalAttrExpr tConss) attrExprs case lefts eAttrs of err:_ -> pure (Just err) @@ -270,8 +269,7 @@ attrs = A.attributesFromList (rights eAttrs) emptyRelation = Relation attrs emptyTupleSet -evalDatabaseContextExpr (Undefine relVarName) = do - deleteRelVar relVarName +evalDatabaseContextExpr (Undefine relVarName) = deleteRelVar relVarName evalDatabaseContextExpr (Assign relVarName expr) = do -- in the future, it would be nice to get types from the RelationalExpr instead of needing to evaluate it @@ -325,7 +323,7 @@ let relVarTable = relationVariables context case M.lookup relVarName relVarTable of Nothing -> return $ Just (RelVarNotDefinedError relVarName) - Just rel -> do + Just rel -> case runReader (predicateRestrictionFilter (attributes rel) restrictionPredicateExpr) (RelationalExprStateElems context) of Left err -> return $ Just err Right predicateFunc -> do @@ -334,9 +332,9 @@ if cardinality restrictedPortion == Finite 0 then pure Nothing else do - unrestrictedPortion <- restrict (not . predicateFunc) rel + unrestrictedPortion <- restrict (predicateFunc >=> (pure . not)) rel updatedPortion <- relMap (updateTupleWithAtomExprs atomExprMap context) restrictedPortion - updatedRel <- union updatedPortion unrestrictedPortion + updatedRel <- updatedPortion `union` unrestrictedPortion pure (Just updatedRel) case ret of Left err -> pure (Just err) @@ -399,21 +397,18 @@ -- validate that the constructor's types exist case validateTypeConstructorDef tConsDef dConsDefList of errs@(_:_) -> pure $ Just (someErrors errs) - [] -> do - if T.length tConsName < 1 || not (isUpper (T.head tConsName)) then - pure $ Just (InvalidAtomTypeName tConsName) - else if isJust (findTypeConstructor tConsName oldTypes) then - pure $ Just (AtomTypeNameInUseError tConsName) - else do - let newTypes = oldTypes ++ [(tConsDef, dConsDefList)] - putStateContext $ currentContext { typeConstructorMapping = newTypes } - pure Nothing + [] | T.null tConsName || not (isUpper (T.head tConsName)) -> pure $ Just (InvalidAtomTypeName tConsName) + | isJust (findTypeConstructor tConsName oldTypes) -> pure $ Just (AtomTypeNameInUseError tConsName) + | otherwise -> do + let newTypes = oldTypes ++ [(tConsDef, dConsDefList)] + putStateContext $ currentContext { typeConstructorMapping = newTypes } + pure Nothing -- | Removing the atom constructor prevents new atoms of the type from being created. Existing atoms of the type remain. Thus, the atomTypes list in the DatabaseContext need not be all-inclusive. evalDatabaseContextExpr (RemoveTypeConstructor tConsName) = do currentContext <- getStateContext let oldTypes = typeConstructorMapping currentContext - if findTypeConstructor tConsName oldTypes == Nothing then + if isNothing (findTypeConstructor tConsName oldTypes) then pure $ Just (AtomTypeNameNotInUseError tConsName) else do let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes @@ -425,8 +420,8 @@ evald <- forM exprs evalDatabaseContextExpr --some lifting magic needed here case catMaybes evald of - [] -> return $ Nothing - err:_ -> return $ Just err + [] -> pure Nothing + err:_ -> pure (Just err) evalDatabaseContextExpr (RemoveAtomFunction funcName) = do currentContext <- getStateContext @@ -466,7 +461,7 @@ actualArgCount = length atomArgExprs if expectedArgCount /= actualArgCount then pure (Just (FunctionArgumentCountMismatch expectedArgCount actualArgCount)) - else do + else --check that the atom types are valid case lefts eAtomTypes of _:_ -> pure (Just (someErrors (lefts eAtomTypes))) @@ -479,15 +474,15 @@ eAtomArgs = map (\arg -> runReader (evalAtomExpr emptyTuple arg) relExprState) atomArgExprs if length (lefts eAtomArgs) > 1 then pure (Just (someErrors (lefts eAtomArgs))) - else if length typeErrors > 0 then + else if not (null typeErrors) then pure (Just (someErrors typeErrors)) - else do + else case evalDatabaseContextFunction func (rights eAtomArgs) context of Left err -> pure (Just err) Right newContext -> putStateContext newContext >> pure Nothing evalDatabaseContextIOExpr :: Maybe ScriptSession -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext) -evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcName funcType script) = do +evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcName funcType script) = case mScriptSession of Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError)) Just scriptSession -> do @@ -511,7 +506,7 @@ -- check if the name is already in use if HS.member funcName (HS.map atomFuncName atomFuncs) then Left (FunctionNameInUseError funcName) - else do + else Right newContext case res of Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc))) @@ -519,7 +514,7 @@ Left err -> pure (Left err) Right context' -> pure (Right context') -evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunction funcName funcType script) = do +evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunction funcName funcType script) = case mScriptSession of Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError)) Just scriptSession -> do @@ -551,7 +546,7 @@ -- check if the name is already in use if HS.member funcName (HS.map dbcFuncName dbcFuncs) then Left (FunctionNameInUseError funcName) - else do + else Right newContext case res of Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc))) @@ -560,7 +555,7 @@ Right context' -> pure (Right context') -updateTupleWithAtomExprs :: (M.Map AttributeName AtomExpr) -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple +updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple updateTupleWithAtomExprs exprMap context tupIn = do --resolve all atom exprs atomsAssoc <- mapM (\(attrName, atomExpr) -> do @@ -614,52 +609,73 @@ Right val -> pure val {- used for restrictions- take the restrictionpredicate and return the corresponding filter function -} -predicateRestrictionFilter :: Attributes -> RestrictionPredicateExpr -> RelationalExprState (Either RelationalError (RelationTuple -> Bool)) -predicateRestrictionFilter attrs (AndPredicate expr1 expr2) = do +predicateRestrictionFilter :: Attributes -> RestrictionPredicateExpr -> RelationalExprState (Either RelationalError RestrictionFilter) +predicateRestrictionFilter attrs (AndPredicate expr1 expr2) = runExceptT $ do expr1v <- liftE (predicateRestrictionFilter attrs expr1) expr2v <- liftE (predicateRestrictionFilter attrs expr2) - pure (\x -> expr1v x && expr2v x) + pure (\x -> do + ev1 <- expr1v x + ev2 <- expr2v x + pure (ev1 && ev2)) -predicateRestrictionFilter attrs (OrPredicate expr1 expr2) = do +predicateRestrictionFilter attrs (OrPredicate expr1 expr2) = runExceptT $ do expr1v <- liftE (predicateRestrictionFilter attrs expr1) expr2v <- liftE (predicateRestrictionFilter attrs expr2) - pure (\x -> expr1v x || expr2v x) + pure (\x -> do + ev1 <- expr1v x + ev2 <- expr2v x + pure (ev1 || ev2)) -predicateRestrictionFilter _ TruePredicate = pure (Right (\_ -> True)) +predicateRestrictionFilter _ TruePredicate = pure (Right (\_ -> pure True)) -predicateRestrictionFilter attrs (NotPredicate expr) = do +predicateRestrictionFilter attrs (NotPredicate expr) = runExceptT $ do exprv <- liftE (predicateRestrictionFilter attrs expr) - pure (\x -> not (exprv x)) + pure (\x -> do + ev <- exprv x + pure (not ev)) -predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = runExceptT $ do - --merge attrs into to state attributes - rel <- liftE (evalRelationalExpr relExpr) - if rel == relationTrue then - pure (\_ -> True) - else if rel == relationFalse then - pure (\_ -> False) - else - throwE (PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'") +--optimization opportunity: if the subexpression does not reference attributes in the top-level expression, then it need only be evaluated once, statically, outside the tuple filter- see historical implementation here +predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do + rstate <- ask + pure (Right (\tup -> case runReader (evalRelationalExpr relExpr) (mergeTuplesIntoRelationalExprState tup rstate) of + Left err -> Left err + Right rel -> if arity rel /= 0 then + Left (PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'") + else + pure (rel == relationTrue))) predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr) = do - --merge attrs into the state attributes rstate <- ask + let (attrs', ctxtup') = case rstate of + RelationalExprStateElems _ -> (attrs, emptyTuple) + RelationalExprStateAttrsElems _ _ -> (attrs, emptyTuple) + RelationalExprStateTupleElems _ ctxtup -> (A.union attrs (tupleAttributes ctxtup), ctxtup) runExceptT $ do - atomExprType <- liftE (typeFromAtomExpr attrs atomExpr) - attr <- either throwE pure (A.attributeForName attrName attrs) + atomExprType <- liftE (typeFromAtomExpr attrs' atomExpr) + attr <- either throwE pure $ case A.attributeForName attrName attrs of + Right attr -> Right attr + Left (NoSuchAttributeNamesError _) -> case A.attributeForName attrName (tupleAttributes ctxtup') of + Right ctxattr -> Right ctxattr + Left err2@(NoSuchAttributeNamesError _) -> Left err2 + Left err -> Left err + Left err -> Left err if atomExprType /= A.atomType attr then throwE (TupleAttributeTypeMismatchError (A.attributesFromList [attr])) else - pure $ \tupleIn -> case atomForAttributeName attrName tupleIn of - Left _ -> False - Right atomIn -> - let atomEvald = runReader (evalAtomExpr tupleIn atomExpr) rstate in - case atomEvald of - Right atomCmp -> atomCmp == atomIn - Left _ -> False + pure $ \tupleIn -> let evalAndCmp atomIn = case atomEvald of + Right atomCmp -> atomCmp == atomIn + Left _ -> False + atomEvald = runReader (evalAtomExpr tupleIn atomExpr) rstate + in + pure $ case atomForAttributeName attrName tupleIn of + Left (NoSuchAttributeNamesError _) -> case atomForAttributeName attrName ctxtup' of + Left _ -> False + Right ctxatom -> evalAndCmp ctxatom + Left _ -> False + Right atomIn -> evalAndCmp atomIn -- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance predicateRestrictionFilter attrs (AtomExprPredicate atomExpr) = do --merge attrs into the state attributes @@ -669,14 +685,14 @@ if aType /= BoolAtomType then throwE (AtomTypeMismatchError aType BoolAtomType) else - pure (\tupleIn -> do - case runReader (evalAtomExpr tupleIn atomExpr) rstate of + pure (\tupleIn -> + pure $ case runReader (evalAtomExpr tupleIn atomExpr) rstate of Left _ -> False Right boolAtomValue -> boolAtomValue == BoolAtom True) tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation -tupleExprCheckNewAttrName attrName rel = if isRight $ attributeForName attrName rel then - Left $ AttributeNameInUseError attrName +tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName rel) then + Left (error "SPAMMIT" $ AttributeNameInUseError attrName) else Right rel @@ -691,7 +707,7 @@ atomExprType' <- liftE (verifyAtomExprTypes relIn atomExpr atomExprType) let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType'] newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs - pure $ (newAndOldAttrs, \tup -> let substate = mergeTuplesIntoRelationalExprState tup rstate in case runReader (evalAtomExpr tup atomExpr) substate of + pure (newAndOldAttrs, \tup -> let substate = mergeTuplesIntoRelationalExprState tup rstate in case runReader (evalAtomExpr tup atomExpr) substate of Left err -> Left err Right atom -> Right (tupleAtomExtend newAttrName atom tup) ) @@ -709,7 +725,7 @@ evalAtomExpr _ (NakedAtomExpr atom) = pure (Right atom) evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do argTypes <- mapM (typeFromAtomExpr (tupleAttributes tupIn)) arguments - context <- liftM stateElemsContext ask + context <- fmap stateElemsContext ask runExceptT $ do let functions = atomFunctions context func <- either throwE pure (atomFunctionForName funcName functions) @@ -722,10 +738,13 @@ throwE (FunctionArgumentCountMismatch expectedArgCount actualArgCount) else do _ <- mapM (\(expType, actType) -> either throwE pure (atomTypeVerify expType actType)) (safeInit (zip (atomFuncType func) argTypes)) - evaldArgs <- mapM (\arg -> liftE (evalAtomExpr tupIn arg)) arguments + evaldArgs <- mapM (liftE . evalAtomExpr tupIn) arguments case evalAtomFunction func evaldArgs of Left err -> throwE (AtomFunctionUserError err) - Right result -> pure result + Right result -> do + --validate that the result matches the expected type + _ <- either throwE pure (atomTypeVerify (last (atomFuncType func)) (atomTypeForAtom result)) + pure result evalAtomExpr tupIn (RelationAtomExpr relExpr) = do --merge existing state tuple context into new state tuple context to support an arbitrary number of levels, but new attributes trounce old attributes rstate <- ask @@ -742,28 +761,27 @@ typeFromAtomExpr :: Attributes -> AtomExpr -> RelationalExprState (Either RelationalError AtomType) typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do - --first, check if the attribute is in the immediate attributes rstate <- ask case A.atomTypeForAttributeName attrName attrs of Right aType -> pure (Right aType) Left err@(NoSuchAttributeNamesError _) -> case rstate of RelationalExprStateAttrsElems _ attrs' -> case A.attributeForName attrName attrs' of - Left err' -> pure (Left err') + Left err' -> pure (error "SPAMMO2" $ Left err') Right attr -> pure (Right (A.atomType attr)) - RelationalExprStateElems _ -> pure (Left err) + RelationalExprStateElems _ -> pure (error (show attrs) $ Left err) RelationalExprStateTupleElems _ tup -> case atomForAttributeName attrName tup of - Left err' -> pure (Left err') + Left err' -> pure (error "STAMP" $ Left err') Right atom -> pure (Right (atomTypeForAtom atom)) - Left err -> pure (Left err) + Left err -> pure (error "GONK" $ Left err) typeFromAtomExpr _ (NakedAtomExpr atom) = pure (Right (atomTypeForAtom atom)) typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do - context <- liftM stateElemsContext ask + context <- fmap stateElemsContext ask let funcs = atomFunctions context case atomFunctionForName funcName funcs of Left err -> pure (Left err) Right func -> do let funcRetType = last (atomFuncType func) - funcArgTypes = reverse (tail (reverse (atomFuncType func))) + funcArgTypes = init (atomFuncType func) eArgTypes <- mapM (typeFromAtomExpr attrs) atomArgs case lefts eArgTypes of errs@(_:_) -> pure (Left (someErrors errs)) @@ -780,8 +798,8 @@ -- grab the type of the data constructor, then validate that the args match the expected types typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) = runExceptT $ do - argsTypes <- mapM (\arg -> liftE (typeFromAtomExpr attrs arg)) dConsArgs - context <- liftM stateElemsContext (lift ask) + argsTypes <- mapM (liftE . typeFromAtomExpr attrs) dConsArgs + context <- fmap stateElemsContext (lift ask) aType <- either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes) pure aType @@ -795,7 +813,7 @@ RelationalExprStateTupleElems _ _ -> throwE err RelationalExprStateElems _ -> throwE err RelationalExprStateAttrsElems _ attrs -> case A.attributeForName attrName attrs of - Left err' -> throwE err' + Left err' -> throwE (error "GONK" err') Right attrType -> either throwE pure (atomTypeVerify expectedType (A.atomType attrType)) Left err -> throwE err verifyAtomExprTypes _ (NakedAtomExpr atom) expectedType = pure (atomTypeVerify expectedType (atomTypeForAtom atom)) @@ -808,18 +826,18 @@ let expectedArgTypes = atomFuncType func funcArgTypes <- mapM (\(atomExpr,expectedType2,argCount) -> case runReader (verifyAtomExprTypes relIn atomExpr expectedType2) rstate of Left (AtomTypeMismatchError expSubType actSubType) -> throwE (AtomFunctionTypeError funcName argCount expSubType actSubType) - Left err -> throwE (err) + Left err -> throwE err Right x -> pure x ) $ zip3 funcArgExprs expectedArgTypes [1..] if length funcArgTypes /= length expectedArgTypes - 1 then throwE (AtomTypeCountError funcArgTypes expectedArgTypes) - else do + else either throwE pure (atomTypeVerify expectedType (last expectedArgTypes)) verifyAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType = runExceptT $ do rstate <- lift ask relType <- either throwE pure (runReader (typeForRelationalExpr relationExpr) (mergeAttributesIntoRelationalExprState (attributes relIn) rstate)) either throwE pure (atomTypeVerify expectedType (RelationAtomType (attributes relType))) -verifyAtomExprTypes rel cons@(ConstructedAtomExpr _ _ _) expectedType = runExceptT $ do +verifyAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = runExceptT $ do cType <- liftE (typeFromAtomExpr (attributes rel) cons) either throwE pure (atomTypeVerify expectedType cType) @@ -833,7 +851,7 @@ evalTupleExpr :: Maybe Attributes -> TupleExpr -> RelationalExprState (Either RelationalError RelationTuple) evalTupleExpr attrs (TupleExpr tupMap) = do - context <- liftM stateElemsContext ask + context <- fmap stateElemsContext ask runExceptT $ do -- it's not possible for AtomExprs in tuple constructors to reference other Attributes' atoms due to the necessary order-of-operations (need a tuple to pass to evalAtomExpr)- it may be possible with some refactoring of type usage or delayed evaluation- needs more thought, but not a priority -- I could adjust this logic so that when the attributes are not specified (Nothing), then I can attempt to extract the attributes from the tuple- the type resolution will blow up if an ambiguous data constructor is used (Left 4) and this should allow simple cases to "relation{tuple{a 4}}" to be processed diff --git a/src/lib/ProjectM36/ScriptSession.hs b/src/lib/ProjectM36/ScriptSession.hs --- a/src/lib/ProjectM36/ScriptSession.hs +++ b/src/lib/ProjectM36/ScriptSession.hs @@ -30,7 +30,7 @@ dbcFunctionBodyType :: Type } -data ScriptSessionError = ScriptSessionLoadError GhcException +newtype ScriptSessionError = ScriptSessionLoadError GhcException deriving (Show) -- | Configure a GHC environment/session which we will use for all script compilation. @@ -44,7 +44,7 @@ dflags <- getSessionDynFlags let ghcVersion = projectVersion dflags - sandboxPkgPaths <- liftIO $ liftM concat $ mapM glob [ + sandboxPkgPaths <- liftIO $ concat <$> mapM glob [ "./dist-newstyle/packagedb/ghc-" ++ ghcVersion, ".cabal-sandbox/*ghc-" ++ ghcVersion ++ "-packages.conf.d", homeDir ".cabal/store/ghc-" ++ ghcVersion ++ "/package.db" @@ -61,7 +61,7 @@ #if __GLASGOW_HASKELL__ >= 800 trustFlags = map TrustPackage required_packages, #endif - packageFlags = (packageFlags dflags) ++ packages, + packageFlags = packageFlags dflags ++ packages, extraPkgConfs = const (localPkgPaths ++ [UserPkgConf, GlobalPkgConf]) } applyGopts flags = foldl gopt_set flags gopts @@ -100,7 +100,7 @@ ideclSource = False, ideclSafe = True, ideclImplicit = False, - ideclQualified = (isJust mQual), + ideclQualified = isJust mQual, ideclAs = mQual, ideclHiding = Nothing } @@ -114,6 +114,7 @@ "ProjectM36.Relation", "ProjectM36.AtomFunctionError", "ProjectM36.DatabaseContextFunctionError", + "ProjectM36.DatabaseContextFunctionUtils", "ProjectM36.RelationalExpression"] qualifiedModules = map (\(modn, qualNam) -> IIDecl $ safeImportDecl (mkModuleName modn) (Just (mkModuleName qualNam))) [ ("Data.Text", "T") @@ -138,7 +139,7 @@ case lBodyName of [] -> error ("failed to parse " ++ name) _:_:_ -> error "too many name matches" - bodyName:[] -> do + [bodyName] -> do mThing <- lookupName bodyName case mThing of Nothing -> error ("failed to find " ++ name) diff --git a/src/lib/ProjectM36/Server.hs b/src/lib/ProjectM36/Server.hs --- a/src/lib/ProjectM36/Server.hs +++ b/src/lib/ProjectM36/Server.hs @@ -33,13 +33,15 @@ handleCall (\conn (RetrieveHeadTransactionId sessionId) -> handleRetrieveHeadTransactionId ti sessionId conn), handleCall (\conn (RetrieveTransactionGraph sessionId) -> handleRetrieveTransactionGraph ti sessionId conn), handleCall (\conn (Login procId) -> handleLogin ti conn procId), - handleCall (\conn (CreateSessionAtHead headn) -> handleCreateSessionAtHead ti headn conn), - handleCall (\conn (CreateSessionAtCommit commitId) -> handleCreateSessionAtCommit ti commitId conn), + handleCall (\conn (CreateSessionAtHead headn) -> handleCreateSessionAtHead ti conn headn), + handleCall (\conn (CreateSessionAtCommit commitId) -> handleCreateSessionAtCommit ti conn commitId), handleCall (\conn (CloseSession sessionId) -> handleCloseSession ti sessionId conn), handleCall (\conn (RetrieveAtomTypesAsRelation sessionId) -> handleRetrieveAtomTypesAsRelation ti sessionId conn), handleCall (\conn (RetrieveRelationVariableSummary sessionId) -> handleRetrieveRelationVariableSummary ti sessionId conn), handleCall (\conn (RetrieveCurrentSchemaName sessionId) -> handleRetrieveCurrentSchemaName ti sessionId conn), handleCall (\conn (ExecuteSchemaExpr sessionId schemaExpr) -> handleExecuteSchemaExpr ti sessionId conn schemaExpr), + handleCall (\conn (RetrieveSessionIsDirty sessionId) -> handleRetrieveSessionIsDirty ti sessionId conn), + handleCall (\conn (ExecuteAutoMergeToHead sessionId strat headName') -> handleExecuteAutoMergeToHead ti sessionId conn strat headName'), handleCall (\conn Logout -> handleLogout ti conn) ] ++ testModeHandlers, unhandledMessagePolicy = Terminate @@ -73,7 +75,7 @@ loggingNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received \"" ++ show notName ++ "\": " ++ show evaldNot -- | A synchronous function to start the project-m36 daemon given an appropriate 'ServerConfig'. Note that this function only returns if the server exits. Returns False if the daemon exited due to an error. If the second argument is not Nothing, the port is put after the server is ready to service the port. -launchServer :: ServerConfig -> Maybe (MVar EndPointAddress) -> IO (Bool) +launchServer :: ServerConfig -> Maybe (MVar EndPointAddress) -> IO Bool launchServer daemonConfig mAddressMVar = do econn <- connectProjectM36 (InProcessConnectionInfo (persistenceStrategy daemonConfig) loggingNotificationCallback (ghcPkgPaths daemonConfig)) case econn of @@ -96,7 +98,7 @@ runProcess localTCPNode $ do let testBool = testMode daemonConfig reqTimeout = perRequestTimeout daemonConfig - serve (conn, databaseName daemonConfig, mAddressMVar, (address endpoint)) initServer (serverDefinition testBool reqTimeout) + serve (conn, databaseName daemonConfig, mAddressMVar, address endpoint) initServer (serverDefinition testBool reqTimeout) liftIO $ putStrLn "serve returned" pure True diff --git a/src/lib/ProjectM36/Server/EntryPoints.hs b/src/lib/ProjectM36/Server/EntryPoints.hs --- a/src/lib/ProjectM36/Server/EntryPoints.hs +++ b/src/lib/ProjectM36/Server/EntryPoints.hs @@ -13,7 +13,7 @@ import Control.Concurrent (threadDelay) timeoutOrDie :: Serializable a => Timeout -> IO a -> Process (Either ServerError a) -timeoutOrDie micros act = do +timeoutOrDie micros act = if micros == 0 then liftIO act >>= \x -> pure (Right x) else do @@ -35,17 +35,17 @@ ret <- timeoutOrDie ti (executeRelationalExpr sessionId conn expr) reply ret conn -handleExecuteDatabaseContextExpr :: Timeout -> SessionId -> Connection -> DatabaseContextExpr -> Reply (Maybe RelationalError) +handleExecuteDatabaseContextExpr :: Timeout -> SessionId -> Connection -> DatabaseContextExpr -> Reply (Either RelationalError ()) handleExecuteDatabaseContextExpr ti sessionId conn dbexpr = do ret <- timeoutOrDie ti (executeDatabaseContextExpr sessionId conn dbexpr) reply ret conn -handleExecuteDatabaseContextIOExpr :: Timeout -> SessionId -> Connection -> DatabaseContextIOExpr -> Reply (Maybe RelationalError) +handleExecuteDatabaseContextIOExpr :: Timeout -> SessionId -> Connection -> DatabaseContextIOExpr -> Reply (Either RelationalError ()) handleExecuteDatabaseContextIOExpr ti sessionId conn dbexpr = do ret <- timeoutOrDie ti (executeDatabaseContextIOExpr sessionId conn dbexpr) reply ret conn -handleExecuteHeadName :: Timeout -> SessionId -> Connection -> Reply (Maybe HeadName) +handleExecuteHeadName :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError HeadName) handleExecuteHeadName ti sessionId conn = do ret <- timeoutOrDie ti (headName sessionId conn) reply ret conn @@ -57,7 +57,7 @@ Right () -> reply (Right True) conn Left err -> reply (Left err) conn -handleExecuteGraphExpr :: Timeout -> SessionId -> Connection -> TransactionGraphOperator -> Reply (Maybe RelationalError) +handleExecuteGraphExpr :: Timeout -> SessionId -> Connection -> TransactionGraphOperator -> Reply (Either RelationalError ()) handleExecuteGraphExpr ti sessionId conn graphExpr = do ret <- timeoutOrDie ti (executeGraphExpr sessionId conn graphExpr) reply ret conn @@ -87,19 +87,19 @@ ret <- timeoutOrDie ti (transactionGraphAsRelation sessionId conn) reply ret conn -handleRetrieveHeadTransactionId :: Timeout -> SessionId -> Connection -> Reply (Maybe TransactionId) +handleRetrieveHeadTransactionId :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError TransactionId) handleRetrieveHeadTransactionId ti sessionId conn = do ret <- timeoutOrDie ti (headTransactionId sessionId conn) reply ret conn -handleCreateSessionAtCommit :: Timeout -> TransactionId -> Connection -> Reply (Either RelationalError SessionId) -handleCreateSessionAtCommit ti commitId conn = do - ret <- timeoutOrDie ti (createSessionAtCommit commitId conn) +handleCreateSessionAtCommit :: Timeout -> Connection -> TransactionId -> Reply (Either RelationalError SessionId) +handleCreateSessionAtCommit ti conn commitId = do + ret <- timeoutOrDie ti (createSessionAtCommit conn commitId) reply ret conn -handleCreateSessionAtHead :: Timeout -> HeadName -> Connection -> Reply (Either RelationalError SessionId) -handleCreateSessionAtHead ti headn conn = do - ret <- timeoutOrDie ti (createSessionAtHead headn conn) +handleCreateSessionAtHead :: Timeout -> Connection -> HeadName -> Reply (Either RelationalError SessionId) +handleCreateSessionAtHead ti conn headn = do + ret <- timeoutOrDie ti (createSessionAtHead conn headn) reply ret conn handleCloseSession :: Timeout -> SessionId -> Connection -> Reply () @@ -120,24 +120,34 @@ ret <- timeoutOrDie ti (relationVariablesAsRelation sessionId conn) reply ret conn -handleRetrieveCurrentSchemaName :: Timeout -> SessionId -> Connection -> Reply (Maybe SchemaName) +handleRetrieveCurrentSchemaName :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError SchemaName) handleRetrieveCurrentSchemaName ti sessionId conn = do ret <- timeoutOrDie ti (currentSchemaName sessionId conn) reply ret conn -handleExecuteSchemaExpr :: Timeout -> SessionId -> Connection -> SchemaExpr -> Reply (Maybe RelationalError) +handleExecuteSchemaExpr :: Timeout -> SessionId -> Connection -> SchemaExpr -> Reply (Either RelationalError ()) handleExecuteSchemaExpr ti sessionId conn schemaExpr = do ret <- timeoutOrDie ti (executeSchemaExpr sessionId conn schemaExpr) reply ret conn handleLogout :: Timeout -> Connection -> Reply Bool -handleLogout _ conn = do +handleLogout _ = --liftIO $ closeRemote_ conn - reply (pure True) conn + reply (pure True) handleTestTimeout :: Timeout -> SessionId -> Connection -> Reply Bool handleTestTimeout ti _ conn = do ret <- timeoutOrDie ti (threadDelay 100000 >> pure True) + reply ret conn + +handleRetrieveSessionIsDirty :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Bool) +handleRetrieveSessionIsDirty ti sessionId conn = do + ret <- timeoutOrDie ti (disconnectedTransactionIsDirty sessionId conn) + reply ret conn + +handleExecuteAutoMergeToHead :: Timeout -> SessionId -> Connection -> MergeStrategy -> HeadName -> Reply (Either RelationalError ()) +handleExecuteAutoMergeToHead ti sessionId conn strat headName' = do + ret <- timeoutOrDie ti (autoMergeToHead sessionId conn strat headName') reply ret conn diff --git a/src/lib/ProjectM36/Server/RemoteCallTypes.hs b/src/lib/ProjectM36/Server/RemoteCallTypes.hs --- a/src/lib/ProjectM36/Server/RemoteCallTypes.hs +++ b/src/lib/ProjectM36/Server/RemoteCallTypes.hs @@ -9,6 +9,7 @@ import Data.Binary import Control.Distributed.Process (ProcessId) +{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} -- | The initial login message. The argument should be the process id of the initiating client. This ProcessId will receive notification callbacks. data Login = Login ProcessId deriving (Binary, Generic) @@ -55,3 +56,7 @@ deriving (Binary, Generic) data TestTimeout = TestTimeout SessionId deriving (Binary, Generic) +data RetrieveSessionIsDirty = RetrieveSessionIsDirty SessionId + deriving (Binary, Generic) +data ExecuteAutoMergeToHead = ExecuteAutoMergeToHead SessionId MergeStrategy HeadName + deriving (Binary, Generic) diff --git a/src/lib/ProjectM36/StaticOptimizer.hs b/src/lib/ProjectM36/StaticOptimizer.hs --- a/src/lib/ProjectM36/StaticOptimizer.hs +++ b/src/lib/ProjectM36/StaticOptimizer.hs @@ -28,15 +28,16 @@ relType <- typeForRelationalExpr expr case relType of Left err -> return $ Left err - Right relType2 -> if AS.all == attrNameSet then - applyStaticRelationalOptimization expr - else if AttributeNames (attributeNames relType2) == attrNameSet then - applyStaticRelationalOptimization expr - else do - optimizedSubExpression <- applyStaticRelationalOptimization expr - case optimizedSubExpression of - Left err -> return $ Left err - Right optSubExpr -> return $ Right $ Project attrNameSet optSubExpr + Right relType2 + | AS.all == attrNameSet -> + applyStaticRelationalOptimization expr + | AttributeNames (attributeNames relType2) == attrNameSet -> + applyStaticRelationalOptimization expr + | otherwise -> do + optimizedSubExpression <- applyStaticRelationalOptimization expr + case optimizedSubExpression of + Left err -> pure $ Left err + Right optSubExpr -> pure $ Right $ Project attrNameSet optSubExpr applyStaticRelationalOptimization (Union exprA exprB) = do optExprA <- applyStaticRelationalOptimization exprA @@ -77,12 +78,12 @@ else return $ Right (Difference optExprA2 optExprB2) -applyStaticRelationalOptimization e@(Rename _ _ _) = return $ Right e +applyStaticRelationalOptimization e@Rename{} = return $ Right e -applyStaticRelationalOptimization (Group oldAttrNames newAttrName expr) = do +applyStaticRelationalOptimization (Group oldAttrNames newAttrName expr) = return $ Right $ Group oldAttrNames newAttrName expr -applyStaticRelationalOptimization (Ungroup attrName expr) = do +applyStaticRelationalOptimization (Ungroup attrName expr) = return $ Right $ Ungroup attrName expr --remove restriction of nothing @@ -90,18 +91,18 @@ optimizedPredicate <- applyStaticPredicateOptimization predicate case optimizedPredicate of Left err -> return $ Left err - Right optimizedPredicate2 -> if optimizedPredicate2 == TruePredicate then - applyStaticRelationalOptimization expr - else if optimizedPredicate2 == NotPredicate TruePredicate then do - attributesRel <- typeForRelationalExpr expr - case attributesRel of - Left err -> return $ Left err - Right attributesRelA -> return $ Right $ MakeStaticRelation (attributes attributesRelA) emptyTupleSet - else do - optimizedSubExpression <- applyStaticRelationalOptimization expr - case optimizedSubExpression of - Left err -> return $ Left err - Right optSubExpr -> return $ Right $ Restrict optimizedPredicate2 optSubExpr + Right optimizedPredicate2 + | optimizedPredicate2 == TruePredicate -> applyStaticRelationalOptimization expr + | optimizedPredicate2 == NotPredicate TruePredicate -> do + attributesRel <- typeForRelationalExpr expr + case attributesRel of + Left err -> return $ Left err + Right attributesRelA -> return $ Right $ MakeStaticRelation (attributes attributesRelA) emptyTupleSet + | otherwise -> do + optimizedSubExpression <- applyStaticRelationalOptimization expr + case optimizedSubExpression of + Left err -> return $ Left err + Right optSubExpr -> return $ Right $ Restrict optimizedPredicate2 optSubExpr applyStaticRelationalOptimization e@(Equals _ _) = return $ Right e @@ -172,9 +173,9 @@ --for multiple expressions, we must evaluate applyStaticDatabaseOptimization (MultipleExpr exprs) = do context <- getStateContext - let optExprs = evalState substateRunner ((contextWithEmptyTupleSets context), M.empty, False) + let optExprs = evalState substateRunner (contextWithEmptyTupleSets context, M.empty, False) let errors = lefts optExprs - if length errors > 0 then + if not (null errors) then return $ Left (head errors) else return $ Right $ MultipleExpr (rights optExprs) diff --git a/src/lib/ProjectM36/Transaction.hs b/src/lib/ProjectM36/Transaction.hs --- a/src/lib/ProjectM36/Transaction.hs +++ b/src/lib/ProjectM36/Transaction.hs @@ -2,24 +2,29 @@ import ProjectM36.Base import qualified Data.Set as S import qualified Data.UUID as U +import Data.Time.Clock +transactionTimestamp :: Transaction -> UTCTime +transactionTimestamp (Transaction _ (TransactionInfo _ _ stamp) _) = stamp +transactionTimestamp (Transaction _ (MergeTransactionInfo _ _ _ stamp) _) = stamp + transactionParentIds :: Transaction -> S.Set TransactionId -transactionParentIds (Transaction _ (TransactionInfo pId _) _) = S.singleton pId -transactionParentIds (Transaction _ (MergeTransactionInfo pId1 pId2 _) _) = S.fromList [pId1, pId2] +transactionParentIds (Transaction _ (TransactionInfo pId _ _) _) = S.singleton pId +transactionParentIds (Transaction _ (MergeTransactionInfo pId1 pId2 _ _) _) = S.fromList [pId1, pId2] transactionChildIds :: Transaction -> S.Set TransactionId -transactionChildIds (Transaction _ (TransactionInfo _ children) _) = children -transactionChildIds (Transaction _ (MergeTransactionInfo _ _ children) _) = children +transactionChildIds (Transaction _ (TransactionInfo _ children _) _) = children +transactionChildIds (Transaction _ (MergeTransactionInfo _ _ children _) _) = children -- | Create a new transaction which is identical to the original except that a new set of child transaction ids is added. transactionSetChildren :: Transaction -> S.Set TransactionId -> Transaction -transactionSetChildren t@(Transaction _ (TransactionInfo pId _) schemas') childIds = Transaction (transactionId t) (TransactionInfo pId childIds) schemas' -transactionSetChildren t@(Transaction _ (MergeTransactionInfo pId1 pId2 _) schemas') childIds = Transaction (transactionId t) (MergeTransactionInfo pId1 pId2 childIds) schemas' +transactionSetChildren t@(Transaction _ (TransactionInfo pId _ stamp) schemas') childIds = Transaction (transactionId t) (TransactionInfo pId childIds stamp) schemas' +transactionSetChildren t@(Transaction _ (MergeTransactionInfo pId1 pId2 _ stamp) schemas') childIds = Transaction (transactionId t) (MergeTransactionInfo pId1 pId2 childIds stamp) schemas' -- | 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 (TransactionInfo parentId childIds) = TransactionInfo (filterParent parentId filterIds) (S.intersection childIds filterIds) -filterTransactionInfoTransactions filterIds (MergeTransactionInfo parentIdA parentIdB childIds) = MergeTransactionInfo (filterParent parentIdA filterIds) (filterParent parentIdB filterIds) (S.intersection childIds filterIds) +filterTransactionInfoTransactions filterIds (TransactionInfo parentId childIds stamp) = TransactionInfo (filterParent parentId filterIds) (S.intersection childIds filterIds) stamp +filterTransactionInfoTransactions filterIds (MergeTransactionInfo parentIdA parentIdB childIds stamp) = MergeTransactionInfo (filterParent parentIdA filterIds) (filterParent parentIdB filterIds) (S.intersection childIds filterIds) stamp filterParent :: TransactionId -> S.Set TransactionId -> TransactionId filterParent parentId validIds = if S.member parentId validIds then parentId else U.nil diff --git a/src/lib/ProjectM36/Transaction/Persist.hs b/src/lib/ProjectM36/Transaction/Persist.hs --- a/src/lib/ProjectM36/Transaction/Persist.hs +++ b/src/lib/ProjectM36/Transaction/Persist.hs @@ -59,7 +59,7 @@ return $ Left $ MissingTransactionError transId else do relvars <- readRelVars transDir - transInfo <- liftM B.decode $ BS.readFile (transactionInfoPath transDir) + transInfo <- B.decode <$> BS.readFile (transactionInfoPath transDir) incDeps <- readIncDeps transDir typeCons <- readTypeConstructorMapping transDir sschemas <- readSubschemas transDir @@ -80,7 +80,7 @@ finalTransDir = transactionDir dbdir (transactionId trans) context = concreteDatabaseContext trans transDirExists <- doesDirectoryExist finalTransDir - if not transDirExists then do + unless transDirExists $ do --create sub directories mapM_ createDirectory [tempTransDir, relvarsDir tempTransDir, incDepsDir tempTransDir, atomFuncsDir tempTransDir, dbcFuncsDir tempTransDir] writeRelVars sync tempTransDir (relationVariables context) @@ -92,15 +92,14 @@ BS.writeFile (transactionInfoPath tempTransDir) (B.encode $ transactionInfo trans) --move the temp directory to final location renameSync sync tempTransDir finalTransDir - else - return () + pure () writeRelVar :: DiskSync -> FilePath -> (RelVarName, Relation) -> IO () writeRelVar sync transDir (relvarName, rel) = do let relvarPath = relvarsDir transDir T.unpack relvarName writeBSFileSync sync relvarPath (B.encode rel) -writeRelVars :: DiskSync -> FilePath -> (M.Map RelVarName Relation) -> IO () +writeRelVars :: DiskSync -> FilePath -> M.Map RelVarName Relation -> IO () writeRelVars sync transDir relvars = mapM_ (writeRelVar sync transDir) $ M.toList relvars readRelVars :: FilePath -> IO (M.Map RelVarName Relation) @@ -108,7 +107,7 @@ let relvarsPath = relvarsDir transDir relvarNames <- getDirectoryNames relvarsPath relvars <- mapM (\name -> do - rel <- liftM B.decode $ BS.readFile (relvarsPath name) + rel <- B.decode <$> BS.readFile (relvarsPath name) return (T.pack name, rel)) relvarNames return $ M.fromList relvars @@ -121,7 +120,7 @@ funcNames <- getDirectoryNames (atomFuncsDir transDir) --only Haskell script functions can be serialized --we always return the pre-compiled functions - funcs <- mapM (\name -> readAtomFunc transDir name mScriptSession precompiledAtomFunctions) (map T.pack funcNames) + funcs <- mapM ((\name -> readAtomFunc transDir name mScriptSession precompiledAtomFunctions) . T.pack) funcNames pure (HS.union precompiledAtomFunctions (HS.fromList funcs)) --to write the atom functions, we really some bytecode to write (GHCi bytecode?) @@ -131,10 +130,10 @@ writeBSFileSync sync atomFuncPath (B.encode (atomFuncType func, atomFunctionScript func)) --if the script session is enabled, compile the script, otherwise, hard error! -readAtomFunc :: FilePath -> AtomFunctionName -> Maybe ScriptSession -> AtomFunctions -> IO (AtomFunction) +readAtomFunc :: FilePath -> AtomFunctionName -> Maybe ScriptSession -> AtomFunctions -> IO AtomFunction readAtomFunc transDir funcName mScriptSession precompiledFuncs = do let atomFuncPath = atomFuncsDir transDir T.unpack funcName - (funcType, mFuncScript) <- liftM B.decode (BS.readFile atomFuncPath) + (funcType, mFuncScript) <- B.decode <$> BS.readFile atomFuncPath case mFuncScript of --handle pre-compiled case- pull it from the precompiled list Nothing -> case atomFunctionForName funcName precompiledFuncs of @@ -142,7 +141,7 @@ Left _ -> error ("expected precompiled atom function: " ++ T.unpack funcName) Right realFunc -> pure realFunc --handle a real Haskell scripted function- compile and load - Just funcScript -> do + Just funcScript -> case mScriptSession of Nothing -> error "attempted to read serialized AtomFunction without scripting enabled" Just scriptSession -> do @@ -152,9 +151,9 @@ compileScript (atomFunctionBodyType scriptSession) funcScript case eCompiledScript of Left err -> throwIO err - Right compiledScript -> pure (AtomFunction { atomFuncName = funcName, + Right compiledScript -> pure AtomFunction { atomFuncName = funcName, atomFuncType = funcType, - atomFuncBody = AtomFunctionBody (Just funcScript) compiledScript }) + atomFuncBody = AtomFunctionBody (Just funcScript) compiledScript } writeDBCFuncs :: DiskSync -> FilePath -> DatabaseContextFunctions -> IO () writeDBCFuncs sync transDir funcs = mapM_ (writeDBCFunc sync transDir) (HS.toList funcs) @@ -169,18 +168,18 @@ funcNames <- getDirectoryNames (dbcFuncsDir transDir) --only Haskell script functions can be serialized --we always return the pre-compiled functions - funcs <- mapM (\name -> readDBCFunc transDir name mScriptSession precompiledDatabaseContextFunctions) (map T.pack funcNames) + funcs <- mapM ((\name -> readDBCFunc transDir name mScriptSession precompiledDatabaseContextFunctions) . T.pack) funcNames return $ HS.union basicDatabaseContextFunctions (HS.fromList funcs) readDBCFunc :: FilePath -> DatabaseContextFunctionName -> Maybe ScriptSession -> DatabaseContextFunctions -> IO DatabaseContextFunction readDBCFunc transDir funcName mScriptSession precompiledFuncs = do let dbcFuncPath = dbcFuncsDir transDir T.unpack funcName - (funcType, mFuncScript) <- liftM B.decode (BS.readFile dbcFuncPath) + (funcType, mFuncScript) <- B.decode <$> BS.readFile dbcFuncPath case mFuncScript of Nothing -> case databaseContextFunctionForName funcName precompiledFuncs of Left _ -> error ("expected precompiled dbc function: " ++ T.unpack funcName) Right realFunc -> pure realFunc --return precompiled function - Just funcScript -> do + Just funcScript -> case mScriptSession of Nothing -> error "attempted to read serialized AtomFunction without scripting enabled" Just scriptSession -> do @@ -189,12 +188,12 @@ compileScript (dbcFunctionBodyType scriptSession) funcScript case eCompiledScript of Left err -> throwIO err - Right compiledScript -> pure (DatabaseContextFunction { dbcFuncName = funcName, + Right compiledScript -> pure DatabaseContextFunction { dbcFuncName = funcName, dbcFuncType = funcType, - dbcFuncBody = DatabaseContextFunctionBody (Just funcScript) compiledScript}) + dbcFuncBody = DatabaseContextFunctionBody (Just funcScript) compiledScript} writeIncDep :: DiskSync -> FilePath -> (IncDepName, InclusionDependency) -> IO () -writeIncDep sync transDir (incDepName, incDep) = do +writeIncDep sync transDir (incDepName, incDep) = writeBSFileSync sync (incDepsDir transDir T.unpack incDepName) $ B.encode incDep writeIncDeps :: DiskSync -> FilePath -> M.Map IncDepName InclusionDependency -> IO () @@ -204,13 +203,13 @@ readIncDep transDir incdepName = do let incDepPath = incDepsDir transDir T.unpack incdepName incDepData <- BS.readFile incDepPath - return $ (incdepName, B.decode incDepData) + pure (incdepName, B.decode incDepData) readIncDeps :: FilePath -> IO (M.Map IncDepName InclusionDependency) readIncDeps transDir = do let incDepsPath = incDepsDir transDir incDepNames <- getDirectoryNames incDepsPath - incDeps <- mapM (readIncDep transDir) (map T.pack incDepNames) + incDeps <- mapM (readIncDep transDir . T.pack) incDepNames return $ M.fromList incDeps readSubschemas :: FilePath -> IO Subschemas @@ -228,9 +227,9 @@ writeTypeConstructorMapping sync path types = let atPath = typeConsPath path in writeBSFileSync sync atPath $ B.encode types -readTypeConstructorMapping :: FilePath -> IO (TypeConstructorMapping) +readTypeConstructorMapping :: FilePath -> IO TypeConstructorMapping readTypeConstructorMapping path = do let atPath = typeConsPath path - liftM B.decode (BS.readFile atPath) + B.decode <$> BS.readFile atPath diff --git a/src/lib/ProjectM36/TransactionGraph.hs b/src/lib/ProjectM36/TransactionGraph.hs --- a/src/lib/ProjectM36/TransactionGraph.hs +++ b/src/lib/ProjectM36/TransactionGraph.hs @@ -6,18 +6,31 @@ import ProjectM36.Relation import ProjectM36.TupleSet import ProjectM36.Tuple +import ProjectM36.RelationalExpression +import ProjectM36.TransactionGraph.Merge +import qualified ProjectM36.DisconnectedTransaction as Discon + import qualified Data.Vector as V import qualified ProjectM36.Attribute as A import qualified Data.UUID as U import qualified Data.Set as S import qualified Data.Map as M import Control.Monad +import Data.Time.Clock import qualified Data.Text as T import GHC.Generics import Data.Binary -import ProjectM36.TransactionGraph.Merge import Data.Either (lefts, rights, isRight) +import Data.Monoid +import Control.Arrow +import Data.Maybe +{- +import Debug.Trace +import Control.Monad.Reader +import qualified ProjectM36.DisconnectedTransaction as D +-} + -- | Record a lookup for a specific transaction in the graph. data TransactionIdLookup = TransactionIdLookup TransactionId | TransactionIdHeadNameLookup HeadName [TransactionIdHeadBacktrack] @@ -25,37 +38,35 @@ -- | Used for git-style head backtracking such as topic~3^2. data TransactionIdHeadBacktrack = TransactionIdHeadParentBacktrack Int | -- ^ git equivalent of ~: walk back n parents, arbitrarily choosing a parent when a choice must be made - TransactionIdHeadBranchBacktrack Int -- ^ git equivalent of ^: walk back one parent level to the nth arbitrarily-chosen parent + TransactionIdHeadBranchBacktrack Int | -- ^ git equivalent of ^: walk back one parent level to the nth arbitrarily-chosen parent + TransactionStampHeadBacktrack UTCTime -- ^ git equivalent of 'git-rev-list -n 1 --before X' find the first transaction which was created before the timestamp deriving (Show, Eq, Binary, Generic) -data CommitOption = AllowEmptyCommitOption | -- allow empty commit and add it to the graph - ForbidEmptyCommitOption | --return error on empty commit- probably the safest option - IgnoreEmptyCommitOption -- don't add the commit and don't add it to the graph (no-op) - deriving (Eq, Show, Binary, Generic) -- | Operators which manipulate a transaction graph and which transaction the current 'Session' is based upon. data TransactionGraphOperator = JumpToHead HeadName | JumpToTransaction TransactionId | + WalkBackToTime UTCTime | Branch HeadName | DeleteBranch HeadName | MergeTransactions MergeStrategy HeadName HeadName | - Commit CommitOption | + Commit | Rollback deriving (Eq, Show, Binary, Generic) isCommit :: TransactionGraphOperator -> Bool -isCommit (Commit _) = True +isCommit Commit = True isCommit _ = False data ROTransactionGraphOperator = ShowGraph deriving Show -bootstrapTransactionGraph :: TransactionId -> DatabaseContext -> TransactionGraph -bootstrapTransactionGraph freshId context = TransactionGraph bootstrapHeads bootstrapTransactions +bootstrapTransactionGraph :: UTCTime -> TransactionId -> DatabaseContext -> TransactionGraph +bootstrapTransactionGraph stamp freshId context = TransactionGraph bootstrapHeads bootstrapTransactions where bootstrapHeads = M.singleton "master" freshTransaction newSchemas = Schemas context M.empty - freshTransaction = Transaction freshId (TransactionInfo U.nil S.empty) newSchemas + freshTransaction = Transaction freshId (TransactionInfo U.nil S.empty stamp) newSchemas bootstrapTransactions = S.singleton freshTransaction emptyTransactionGraph :: TransactionGraph @@ -65,7 +76,7 @@ transactionForHead headName graph = M.lookup headName (transactionHeadsForGraph graph) headList :: TransactionGraph -> [(HeadName, TransactionId)] -headList graph = map (\(k,v) -> (k, transactionId v)) (M.assocs (transactionHeadsForGraph graph)) +headList graph = map (second transactionId) (M.assocs (transactionHeadsForGraph graph)) headNameForTransaction :: Transaction -> TransactionGraph -> Maybe HeadName headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchingTrans then @@ -76,48 +87,49 @@ matchingTrans = M.filter (transaction ==) heads transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction -transactionForId tid graph = if tid == U.nil then - Left RootTransactionTraversalError - else if S.null matchingTrans then - Left $ NoSuchTransactionError tid - else - Right $ head (S.toList matchingTrans) +transactionForId tid graph + | tid == U.nil = + Left RootTransactionTraversalError + | S.null matchingTrans = + Left $ NoSuchTransactionError tid + | otherwise = + Right $ head (S.toList matchingTrans) where matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph) transactionsForIds :: S.Set TransactionId -> TransactionGraph -> Either RelationalError (S.Set Transaction) transactionsForIds idSet graph = do - transList <- forM (S.toList idSet) ((flip transactionForId) graph) + transList <- forM (S.toList idSet) (`transactionForId` graph) return (S.fromList transList) isRootTransaction :: Transaction -> TransactionGraph -> Bool -isRootTransaction (Transaction _ (TransactionInfo pId _) _) _ = U.null pId -isRootTransaction (Transaction _ (MergeTransactionInfo _ _ _) _) _ = False +isRootTransaction (Transaction _ (TransactionInfo pId _ _) _) _ = U.null pId +isRootTransaction (Transaction _ MergeTransactionInfo{} _) _ = False -- the first transaction has no parent - all other do have parents- merges have two parents parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction) -parentTransactions (Transaction _ (TransactionInfo pId _) _) graph = do +parentTransactions (Transaction _ (TransactionInfo pId _ _) _) graph = do trans <- transactionForId pId graph return (S.singleton trans) -parentTransactions (Transaction _ (MergeTransactionInfo pId1 pId2 _) _ ) graph = transactionsForIds (S.fromList [pId1, pId2]) graph +parentTransactions (Transaction _ (MergeTransactionInfo pId1 pId2 _ _) _ ) graph = transactionsForIds (S.fromList [pId1, pId2]) graph childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction) -childTransactions (Transaction _ (TransactionInfo _ children) _) = transactionsForIds children -childTransactions (Transaction _ (MergeTransactionInfo _ _ children) _) = transactionsForIds children +childTransactions (Transaction _ (TransactionInfo _ children _) _) = transactionsForIds children +childTransactions (Transaction _ (MergeTransactionInfo _ _ children _) _) = transactionsForIds children -- create a new commit and add it to the heads -- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent) -addBranch :: TransactionId -> HeadName -> TransactionId -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph) -addBranch newId newBranchName branchPointId graph = do +addBranch :: UTCTime -> TransactionId -> HeadName -> TransactionId -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph) +addBranch stamp newId newBranchName branchPointId graph = do parentTrans <- transactionForId branchPointId graph - let newTrans = Transaction newId (TransactionInfo branchPointId S.empty) (schemas parentTrans) + let newTrans = Transaction newId (TransactionInfo branchPointId S.empty stamp) (schemas parentTrans) addTransactionToGraph newBranchName newTrans graph --adds a disconnected transaction to a transaction graph at some head -addDisconnectedTransaction :: TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph) -addDisconnectedTransaction newId headName (DisconnectedTransaction parentId schemas' _) graph = addTransactionToGraph headName (Transaction newId (TransactionInfo parentId S.empty) schemas') graph +addDisconnectedTransaction :: UTCTime -> TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph) +addDisconnectedTransaction stamp newId headName (DisconnectedTransaction parentId schemas' _) = addTransactionToGraph headName (Transaction newId (TransactionInfo parentId S.empty stamp) schemas') addTransactionToGraph :: HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph) @@ -125,7 +137,7 @@ let parentIds = transactionParentIds newTrans childIds = transactionChildIds newTrans newId = transactionId newTrans - validateIds ids = mapM (\i -> transactionForId i graph) (S.toList ids) + validateIds ids = mapM (`transactionForId` graph) (S.toList ids) addChildTransaction trans = transactionSetChildren trans (S.insert newId (transactionChildIds trans)) --validate that the parent transactions are in the graph _ <- validateIds parentIds @@ -135,15 +147,15 @@ Nothing -> pure () -- any headName is OK Just trans -> when (S.notMember (transactionId trans) parentIds) (Left (HeadNameSwitchingHeadProhibitedError headName)) --validate that the transaction has no children - when (not (S.null childIds)) (Left $ NewTransactionMayNotHaveChildrenError newId) + unless (S.null childIds) (Left $ NewTransactionMayNotHaveChildrenError newId) --validate that the trasaction's id is unique when (isRight (transactionForId newId graph)) (Left (TransactionIdInUseError newId)) --update the parent transactions to point to the new transaction - parents <- mapM (\tid -> transactionForId tid graph) (S.toList parentIds) + parents <- mapM (`transactionForId` graph) (S.toList parentIds) let updatedParents = S.map addChildTransaction (S.fromList parents) updatedTransSet = S.insert newTrans (S.union updatedParents (transactionsForGraph graph)) updatedHeads = M.insert headName newTrans (transactionHeadsForGraph graph) - pure (newTrans, (TransactionGraph updatedHeads updatedTransSet)) + pure (newTrans, TransactionGraph updatedHeads updatedTransSet) validateGraph :: TransactionGraph -> Maybe [RelationalError] validateGraph graph@(TransactionGraph _ transSet) = do @@ -194,20 +206,30 @@ -- returns the new "current" transaction, updated graph, and tutorial d result -- the current transaction is not part of the transaction graph until it is committed -evalGraphOp :: TransactionId -> DisconnectedTransaction -> TransactionGraph -> TransactionGraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph) +evalGraphOp :: UTCTime -> TransactionId -> DisconnectedTransaction -> TransactionGraph -> TransactionGraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph) -evalGraphOp _ _ graph (JumpToTransaction jumpId) = case transactionForId jumpId graph of +evalGraphOp _ _ _ graph (JumpToTransaction jumpId) = case transactionForId jumpId graph of Left err -> Left err Right parentTrans -> Right (newTrans, graph) where newTrans = DisconnectedTransaction jumpId (schemas parentTrans) False -- switch from one head to another -evalGraphOp _ _ graph (JumpToHead headName) = +evalGraphOp _ _ _ graph (JumpToHead headName) = case transactionForHead headName graph of Just newHeadTransaction -> let disconnectedTrans = DisconnectedTransaction (transactionId newHeadTransaction) (schemas newHeadTransaction) False in Right (disconnectedTrans, graph) Nothing -> Left $ NoSuchHeadNameError headName + +evalGraphOp _ _ discon graph (WalkBackToTime backTime) = do + let startTransId = Discon.parentId discon + jumpDest <- backtrackGraph graph startTransId (TransactionStampHeadBacktrack backTime) + case transactionForId jumpDest graph of + Left err -> Left err + Right trans -> do + let disconnectedTrans = DisconnectedTransaction (transactionId trans) (schemas trans) False + Right (disconnectedTrans, graph) + -- add new head pointing to branchPoint -- repoint the disconnected transaction to the new branch commit (with a potentially different disconnected context) -- affects transactiongraph and the disconnectedtransaction is recreated based off the branch @@ -223,15 +245,15 @@ -- create a new commit and add it to the heads -- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent) -evalGraphOp newId (DisconnectedTransaction parentId schemas' _) graph (Branch newBranchName) = do +evalGraphOp stamp newId (DisconnectedTransaction parentId schemas' _) graph (Branch newBranchName) = do let newDiscon = DisconnectedTransaction newId schemas' False - case addBranch newId newBranchName parentId graph of + case addBranch stamp newId newBranchName parentId graph of Left err -> Left err Right (_, newGraph) -> Right (newDiscon, newGraph) -- add the disconnected transaction to the graph -- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction -evalGraphOp newTransId discon@(DisconnectedTransaction parentId schemas' _) graph (Commit _) = case transactionForId parentId graph of +evalGraphOp stamp newTransId discon@(DisconnectedTransaction parentId schemas' _) graph Commit = case transactionForId parentId graph of Left err -> Left err Right parentTransaction -> case headNameForTransaction parentTransaction graph of Nothing -> Left $ TransactionIsNotAHeadError parentId @@ -240,18 +262,18 @@ Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph) where newDisconnectedTrans = DisconnectedTransaction newTransId schemas' False - maybeUpdatedGraph = addDisconnectedTransaction newTransId headName discon graph + maybeUpdatedGraph = addDisconnectedTransaction stamp newTransId headName discon graph -- refresh the disconnected transaction, return the same graph -evalGraphOp _ (DisconnectedTransaction parentId _ _) graph Rollback = case transactionForId parentId graph of +evalGraphOp _ _ (DisconnectedTransaction parentId _ _) graph Rollback = case transactionForId parentId graph of Left err -> Left err Right parentTransaction -> Right (newDiscon, graph) where newDiscon = DisconnectedTransaction parentId (schemas parentTransaction) False -evalGraphOp newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) = mergeTransactions newId parentId mergeStrategy (headNameA, headNameB) graph +evalGraphOp stamp newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) = mergeTransactions stamp newId parentId mergeStrategy (headNameA, headNameB) graph -evalGraphOp _ discon graph@(TransactionGraph graphHeads transSet) (DeleteBranch branchName) = case transactionForHead branchName graph of +evalGraphOp _ _ discon graph@(TransactionGraph graphHeads transSet) (DeleteBranch branchName) = case transactionForHead branchName graph of Nothing -> Left (NoSuchHeadNameError branchName) Just _ -> Right (discon, TransactionGraph (M.delete branchName graphHeads) transSet) @@ -262,6 +284,7 @@ mkRelationFromList attrs tupleMatrix where attrs = A.attributesFromList [Attribute "id" TextAtomType, + Attribute "stamp" DateTimeAtomType, Attribute "parents" (RelationAtomType parentAttributes), Attribute "current" BoolAtomType, Attribute "head" TextAtomType @@ -270,16 +293,15 @@ tupleGenerator transaction = case transactionParentsRelation transaction graph of Left err -> Left err Right parentTransRel -> Right [TextAtom $ T.pack $ show (transactionId transaction), + DateTimeAtom (transactionTimestamp transaction), RelationAtom parentTransRel, BoolAtom $ parentId == transactionId transaction, - TextAtom $ case headNameForTransaction transaction graph of - Just headName -> headName - Nothing -> "" + TextAtom $ fromMaybe "" (headNameForTransaction transaction graph) ] transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation -transactionParentsRelation trans graph = do - if isRootTransaction trans graph then do +transactionParentsRelation trans graph = + if isRootTransaction trans graph then mkRelation attrs emptyTupleSet else do parentTransSet <- parentTransactions trans graph @@ -298,20 +320,20 @@ -} -- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph -createMergeTransaction :: TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction -createMergeTransaction newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do +createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction +createMergeTransaction stamp newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do selectedTrans <- validateHeadName selectedBranch graph t2 - pure $ Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) S.empty) (schemas selectedTrans) + pure $ Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) S.empty stamp) (schemas selectedTrans) -- merge functions, relvars, individually -createMergeTransaction newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction newId strat graph t2 +createMergeTransaction stamp newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction stamp newId strat graph t2 -- merge function, relvars, but, on error, just take the component from the preferred branch -createMergeTransaction newId strat@(UnionPreferMergeStrategy _) graph t2 = createUnionMergeTransaction newId strat graph t2 +createMergeTransaction stamp newId strat@(UnionPreferMergeStrategy _) graph t2 = createUnionMergeTransaction stamp newId strat graph t2 -- | Returns the correct Transaction for the branch name in the graph and ensures that it is one of the two transaction arguments in the tuple. validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction -validateHeadName headName graph (t1, t2) = do +validateHeadName headName graph (t1, t2) = case transactionForHead headName graph of Nothing -> Left SelectedHeadMismatchMergeError Just trans -> if trans /= t1 && trans /= t2 then @@ -328,51 +350,51 @@ Right (TransactionGraph resultHeads traverseSet) -- add filter --catch root transaction to improve error? else do - currentTransChildren <- liftM S.fromList $ mapM (flip transactionForId origGraph) (S.toList (transactionChildIds currentTrans)) + currentTransChildren <- S.fromList <$> mapM (`transactionForId` origGraph) (S.toList (transactionChildIds currentTrans)) let searchChildren = S.difference (S.insert currentTrans traverseSet) currentTransChildren searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans traverseSet) childSearches = map searchChild (S.toList searchChildren) errors = lefts childSearches pathsFound = rights childSearches - realErrors = filter (/= (FailedToFindTransactionError goalid)) errors + realErrors = filter (/= FailedToFindTransactionError goalid) errors -- report any non-search-related errors - when (not (null realErrors)) (Left (head realErrors)) + unless (null realErrors) (Left (head realErrors)) -- if no paths found, search the parent if null pathsFound then case oneParent currentTrans of Left RootTransactionTraversalError -> Left (NoCommonTransactionAncestorError currentid goalid) Left err -> Left err - Right currentTransParent -> do + Right currentTransParent -> subGraphOfFirstCommonAncestor origGraph resultHeads currentTransParent goalTrans (S.insert currentTrans traverseSet) else -- we found a path Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound))) where - oneParent (Transaction _ (TransactionInfo parentId _) _) = transactionForId parentId origGraph - oneParent (Transaction _ (MergeTransactionInfo parentId _ _) _) = transactionForId parentId origGraph + oneParent (Transaction _ (TransactionInfo parentId _ _) _) = transactionForId parentId origGraph + oneParent (Transaction _ (MergeTransactionInfo parentId _ _ _) _) = transactionForId parentId origGraph -- | Search from a past graph point to all following heads for a specific transaction. If found, return the transaction path, otherwise a RelationalError. pathToTransaction :: TransactionGraph -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError (S.Set Transaction) pathToTransaction graph currentTransaction targetTransaction accumTransSet = do let targetId = transactionId targetTransaction - if transactionId targetTransaction == transactionId currentTransaction then do + if transactionId targetTransaction == transactionId currentTransaction then Right accumTransSet else do - currentTransChildren <- mapM (flip transactionForId graph) (S.toList (transactionChildIds currentTransaction)) - if length currentTransChildren == 0 then + currentTransChildren <- mapM (`transactionForId` graph) (S.toList (transactionChildIds currentTransaction)) + if null currentTransChildren then Left (FailedToFindTransactionError targetId) else do let searches = map (\t -> pathToTransaction graph t targetTransaction (S.insert t accumTransSet)) currentTransChildren let realErrors = filter (/= FailedToFindTransactionError targetId) (lefts searches) paths = rights searches - if length realErrors > 0 then -- found some real errors + if not (null realErrors) then -- found some real errors Left (head realErrors) - else if length paths == 0 then -- failed to find transaction in all children + else if null paths then -- failed to find transaction in all children Left (FailedToFindTransactionError targetId) else --we have some paths! Right (S.unions paths) -mergeTransactions :: TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph) -mergeTransactions newId parentId mergeStrategy (headNameA, headNameB) graph = do +mergeTransactions :: UTCTime -> TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph) +mergeTransactions stamp newId parentId mergeStrategy (headNameA, headNameB) graph = do let transactionForHeadErr name = case transactionForHead name graph of Nothing -> Left (NoSuchHeadNameError name) Just t -> Right t @@ -382,15 +404,17 @@ let subHeads = M.filterWithKey (\k _ -> elem k [headNameA, headNameB]) (transactionHeadsForGraph graph) subGraph <- subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty subGraph' <- filterSubGraph subGraph subHeads - case createMergeTransaction newId mergeStrategy subGraph' (transA, transB) of + case createMergeTransaction stamp newId mergeStrategy subGraph' (transA, transB) of Left err -> Left (MergeTransactionError err) - Right mergedTrans -> case headNameForTransaction disconParent graph of - Nothing -> Left (TransactionIsNotAHeadError parentId) - Just headName -> do - (newTrans, newGraph) <- addTransactionToGraph headName mergedTrans graph - let newGraph' = TransactionGraph (transactionHeadsForGraph newGraph) (transactionsForGraph newGraph) - newDiscon = DisconnectedTransaction newId (schemas newTrans) False - pure (newDiscon, newGraph') + Right mergedTrans -> case checkConstraints (concreteDatabaseContext mergedTrans) of + Just err -> Left err + Nothing -> case headNameForTransaction disconParent graph of + Nothing -> Left (TransactionIsNotAHeadError parentId) + Just headName -> do + (newTrans, newGraph) <- addTransactionToGraph headName mergedTrans graph + let newGraph' = TransactionGraph (transactionHeadsForGraph newGraph) (transactionsForGraph newGraph) + newDiscon = DisconnectedTransaction newId (schemas newTrans) False + pure (newDiscon, newGraph') --TEMPORARY COPY/PASTE showTransactionStructureX :: Transaction -> TransactionGraph -> String @@ -416,14 +440,14 @@ newHeads = M.map (filterTransaction validIds) heads --helper function for commonalities in union merge -createUnionMergeTransaction :: TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction -createUnionMergeTransaction newId strategy graph (t1,t2) = do +createUnionMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction +createUnionMergeTransaction stamp newId strategy graph (t1,t2) = do let contextA = concreteDatabaseContext t1 contextB = concreteDatabaseContext t2 preference <- case strategy of UnionMergeStrategy -> pure PreferNeither - UnionPreferMergeStrategy preferBranch -> do + UnionPreferMergeStrategy preferBranch -> case transactionForHead preferBranch graph of Nothing -> Left (PreferredHeadMissingMergeError preferBranch) Just preferredTrans -> pure $ if t1 == preferredTrans then PreferFirst else PreferSecond @@ -434,17 +458,18 @@ atomFuncs <- unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB) notifs <- unionMergeMaps preference (notifications contextA) (notifications contextB) types <- unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB) + dbcFuncs <- unionMergeDatabaseContextFunctions preference (dbcFunctions contextA) (dbcFunctions contextB) -- TODO: add merge of subschemas let newContext = DatabaseContext { inclusionDependencies = incDeps, relationVariables = relVars, atomFunctions = atomFuncs, - dbcFunctions = undefined, + dbcFunctions = dbcFuncs, notifications = notifs, typeConstructorMapping = types } newSchemas = Schemas newContext (subschemas t1) - pure (Transaction newId (MergeTransactionInfo (transactionId t1) (transactionId t2) S.empty) newSchemas) + pure (Transaction newId (MergeTransactionInfo (transactionId t1) (transactionId t2) S.empty stamp) newSchemas) lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph @@ -455,7 +480,7 @@ transactionForId traversedId graph traverseGraph :: TransactionGraph -> TransactionId -> [TransactionIdHeadBacktrack] -> Either RelationalError TransactionId -traverseGraph graph currentTid backtrackSteps = foldM (backtrackGraph graph) currentTid backtrackSteps +traverseGraph graph = foldM (backtrackGraph graph) backtrackGraph :: TransactionGraph -> TransactionId -> TransactionIdHeadBacktrack -> Either RelationalError TransactionId -- tilde, step back one parent link- if a choice must be made, choose the "first" link arbitrarily @@ -466,7 +491,7 @@ Left RootTransactionTraversalError else do parentTrans <- transactionForId (head parents) graph - if steps == 1 then do + if steps == 1 then pure (transactionId parentTrans) else backtrackGraph graph (transactionId parentTrans) (TransactionIdHeadParentBacktrack (steps - 1)) @@ -480,4 +505,42 @@ Left (ParentCountTraversalError (S.size parents) steps) else pure (S.elemAt (steps - 1) parents) + +backtrackGraph graph currentTid btrack@(TransactionStampHeadBacktrack stamp) = do + trans <- transactionForId currentTid graph + let parents = transactionParentIds trans + if transactionTimestamp trans < stamp then + pure currentTid + else if S.null parents then + Left RootTransactionTraversalError + else + let arbitraryParent = head (S.toList parents) in + backtrackGraph graph arbitraryParent btrack +-- | Create a temporary branch for commit, merge the result to head, delete the temporary branch. This is useful to atomically commit a transaction, avoiding a TransactionIsNotHeadError but trading it for a potential MergeError. +--this is not a GraphOp because it combines multiple graph operations +autoMergeToHead :: UTCTime -> (TransactionId, TransactionId, TransactionId) -> DisconnectedTransaction -> HeadName -> MergeStrategy -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph) +autoMergeToHead stamp (tempBranchTransId, tempCommitTransId, mergeTransId) discon mergeToHeadName strat graph = do + let tempBranchName = "mergebranch_" <> U.toText tempBranchTransId + --create the temp branch + (discon', graph') <- evalGraphOp stamp tempBranchTransId discon graph (Branch tempBranchName) + + --commit to the new branch- possible future optimization: don't require fsync for this- create a temp commit type + (discon'', graph'') <- evalGraphOp stamp tempCommitTransId discon' graph' Commit + + --jump to merge head + (discon''', graph''') <- evalGraphOp stamp tempBranchTransId discon'' graph'' (JumpToHead mergeToHeadName) + + --create the merge + (discon'''', graph'''') <- evalGraphOp stamp mergeTransId discon''' graph''' (MergeTransactions strat tempBranchName mergeToHeadName) + + --delete the temp branch + (discon''''', graph''''') <- evalGraphOp stamp tempBranchTransId discon'''' graph'''' (DeleteBranch tempBranchName) + {- + let rel = runReader (evalRelationalExpr (RelationVariable "s" ())) (mkRelationalExprState $ D.concreteDatabaseContext discon'''') + traceShowM rel +-} + + pure (discon''''', graph''''') + + diff --git a/src/lib/ProjectM36/TransactionGraph/Merge.hs b/src/lib/ProjectM36/TransactionGraph/Merge.hs --- a/src/lib/ProjectM36/TransactionGraph/Merge.hs +++ b/src/lib/ProjectM36/TransactionGraph/Merge.hs @@ -19,11 +19,11 @@ PreferNeither -> if M.intersection mapA mapB == M.intersection mapA mapB then pure $ M.union mapA mapB else - Left $ StrategyViolatesComponentMergeError + Left StrategyViolatesComponentMergeError -- perform the merge even if the attributes are different- is this what we want? Obviously, we need finer-grained merge options. unionMergeRelation :: MergePreference -> Relation -> Relation -> Either MergeError Relation -unionMergeRelation prefer relA relB = case union relA relB of +unionMergeRelation prefer relA relB = case relA `union` relB of Right unionRel -> pure unionRel Left (AttributeNamesMismatchError _) -> preferredRelVar Left _ -> Left StrategyViolatesRelationVariableMergeError @@ -43,7 +43,7 @@ lookupA = findRel relvarsA lookupB = findRel relvarsB case (lookupA, lookupB) of - (Just relA, Just relB) -> do + (Just relA, Just relB) -> unionMergeRelation prefer relA relB (Nothing, Just relB) -> pure relB (Just relA, Nothing) -> pure relA @@ -65,7 +65,7 @@ foldM (\acc name -> do let findType tcm = case filter (\(t,_) -> TCD.name t == name) tcm of [] -> Nothing - x:[] -> Just x + [x] -> Just x _ -> error "multiple names matching in TypeConstructorMapping" lookupA = findType typesA lookupB = findType typesB @@ -83,3 +83,8 @@ PreferNeither -> Left StrategyViolatesTypeConstructorMergeError ) [] (S.toList allFuncNames) +unionMergeDatabaseContextFunctions :: MergePreference -> DatabaseContextFunctions -> DatabaseContextFunctions -> Either MergeError DatabaseContextFunctions +unionMergeDatabaseContextFunctions prefer funcsA funcsB = case prefer of + PreferFirst -> pure $ HS.union funcsA funcsB + PreferSecond -> pure $ HS.union funcsB funcsA + PreferNeither -> pure $ HS.union funcsA funcsB diff --git a/src/lib/ProjectM36/TransactionGraph/Persist.hs b/src/lib/ProjectM36/TransactionGraph/Persist.hs --- a/src/lib/ProjectM36/TransactionGraph/Persist.hs +++ b/src/lib/ProjectM36/TransactionGraph/Persist.hs @@ -11,6 +11,7 @@ import System.FilePath import System.IO.Temp import System.IO +import Data.Time.Clock.POSIX import qualified Data.UUID as U import qualified Data.Set as S import qualified Data.Map as M @@ -18,24 +19,35 @@ import Data.Text.Encoding import Control.Monad (foldM) import Data.Either (isRight) -import Data.Maybe (catMaybes) +import Data.Maybe (fromMaybe) +import qualified Data.List as L import Control.Exception.Base import qualified Data.Text.IO as TIO import Data.ByteString (ByteString) import Data.Monoid import qualified Crypto.Hash.SHA256 as SHA256 +import Control.Arrow +import Data.Time.Clock +import Data.Text.Read +import System.FilePath.Glob type LockFileHash = ByteString {- -The "m36v1" file at the top-level of the destination directory contains the the transaction graph as a set of transaction ids referencing their parents (1 or more) +The "m36vX" file at the top-level of the destination directory contains the the transaction graph as a set of transaction ids referencing their parents (1 or more) Each Transaction is written to it own directory named by its transaction id. Partially written transactions ids are prefixed with a "." to indicate incompleteness in the graph. Persistence requires a POSIX-compliant, journaled-metadata filesystem. -} +expectedVersion :: Int +expectedVersion = 2 + +transactionLogFileName :: FilePath +transactionLogFileName = "m36v" ++ show expectedVersion + transactionLogPath :: FilePath -> FilePath -transactionLogPath dbdir = dbdir "m36v1" +transactionLogPath dbdir = dbdir transactionLogFileName headsPath :: FilePath -> FilePath headsPath dbdir = dbdir "heads" @@ -49,18 +61,32 @@ - return error or lock file handle which is already locked with a read lock -} +checkForOtherVersions :: FilePath -> IO (Either PersistenceError ()) +checkForOtherVersions dbdir = do + versionMatches <- globDir1 (compile "m36v*") dbdir + let otherVersions = L.delete transactionLogFileName (map takeFileName versionMatches) + if not (null otherVersions) then + pure (Left (WrongDatabaseFormatVersionError transactionLogFileName (head otherVersions))) + else + pure (Right ()) + + setupDatabaseDir :: DiskSync -> FilePath -> TransactionGraph -> IO (Either PersistenceError (Handle, LockFileHash)) setupDatabaseDir sync dbdir bootstrapGraph = do dbdirExists <- doesDirectoryExist dbdir - m36exists <- doesFileExist (transactionLogPath dbdir) - if dbdirExists && m36exists then do - --no directories to write, just - lockFileH <- openLockFile dbdir - gDigest <- bracket_ (lockFile lockFileH WriteLock) (unlockFile lockFileH) (readGraphTransactionIdFileDigest dbdir) - pure (Right (lockFileH, gDigest)) - else if not m36exists then do - locks <- bootstrapDatabaseDir sync dbdir bootstrapGraph - pure (Right locks) + eWrongVersion <- checkForOtherVersions dbdir + case eWrongVersion of + Left err -> pure (Left err) + Right () -> do + m36exists <- doesFileExist (transactionLogPath dbdir) + if dbdirExists && m36exists then do + --no directories to write, just + lockFileH <- openLockFile dbdir + gDigest <- bracket_ (lockFile lockFileH WriteLock) (unlockFile lockFileH) (readGraphTransactionIdFileDigest dbdir) + pure (Right (lockFileH, gDigest)) + else if not m36exists then do + locks <- bootstrapDatabaseDir sync dbdir bootstrapGraph + pure (Right locks) else pure (Left (InvalidDirectoryError dbdir)) {- @@ -70,10 +96,11 @@ bootstrapDatabaseDir sync dbdir bootstrapGraph = do createDirectory dbdir lockFileH <- openLockFile dbdir - digest <- bracket_ (lockFile lockFileH WriteLock) (unlockFile lockFileH) (transactionGraphPersist sync dbdir bootstrapGraph) + let allTransIds = map transactionId (S.toList (transactionsForGraph bootstrapGraph)) + digest <- bracket_ (lockFile lockFileH WriteLock) (unlockFile lockFileH) (transactionGraphPersist sync dbdir allTransIds bootstrapGraph) pure (lockFileH, digest) -openLockFile :: FilePath -> IO (Handle) +openLockFile :: FilePath -> IO Handle openLockFile dbdir = do lockFileH <- openFile (lockFilePath dbdir) WriteMode pure lockFileH @@ -85,19 +112,25 @@ -assume that all non-head transactions have already been written because this is an incremental (and concurrent!) write method --store the head names with a symlink to the transaction under "heads" -} -transactionGraphPersist :: DiskSync -> FilePath -> TransactionGraph -> IO LockFileHash -transactionGraphPersist sync destDirectory graph = do - transactionHeadTransactionsPersist sync destDirectory graph +transactionGraphPersist :: DiskSync -> FilePath -> [TransactionId] -> TransactionGraph -> IO LockFileHash +transactionGraphPersist sync destDirectory transIds graph = do + transactionsPersist sync transIds destDirectory graph --write graph file newDigest <- writeGraphTransactionIdFile sync destDirectory graph --write heads file transactionGraphHeadsPersist sync destDirectory graph pure newDigest --- | The incremental writer which only writes from the set of heads. New heads must be written on every commit. Most heads will already be written on every commit. -transactionHeadTransactionsPersist :: DiskSync -> FilePath -> TransactionGraph -> IO () -transactionHeadTransactionsPersist sync destDirectory graphIn = mapM_ (writeTransaction sync destDirectory) $ M.elems (transactionHeadsForGraph graphIn) - +-- | The incremental writer writes the transactions ids specified by the second argument. + +-- There was a bug here via #128 because automerge added multiple transactions to the graph but this function used to only write the head transactions from the graph. Automerge creates multiple transactions, so these are now passed in as the second argument. +transactionsPersist :: DiskSync -> [TransactionId] -> FilePath -> TransactionGraph -> IO () +transactionsPersist sync transIds destDirectory graphIn = mapM_ writeTrans transIds + where writeTrans tid = + case transactionForId tid graphIn of + Left err -> error ("writeTransaction: " ++ show err) + Right trans -> writeTransaction sync destDirectory trans + {- write graph heads to a file which can be atomically swapped -} @@ -115,10 +148,10 @@ transactionGraphHeadsLoad :: FilePath -> IO [(HeadName,TransactionId)] transactionGraphHeadsLoad dbdir = do headsData <- readFile (headsPath dbdir) - let headsAssocs = map (\l -> let headName:uuidStr:[] = words l in + let headsAssocs = map (\l -> let [headName, uuidStr] = words l in (headName,uuidStr) ) (lines headsData) - return [(T.pack headName, uuid) | (headName, Just uuid) <- map (\(h,u) -> (h, U.fromString u)) headsAssocs] + return [(T.pack headName, uuid) | (headName, Just uuid) <- map (second U.fromString) headsAssocs] {- load any transactions which are not already part of the incoming transaction graph @@ -133,10 +166,10 @@ case uuidInfo of Left err -> return $ Left err Right info -> do - let folder = \eitherGraph transId -> case eitherGraph of + let folder eitherGraph transId = case eitherGraph of Left err -> return $ Left err Right graph -> readTransactionIfNecessary dbdir transId mScriptSession graph - loadedGraph <- foldM folder (Right graphIn) (map fst info) + loadedGraph <- foldM folder (Right graphIn) (map (\(tid,_,_) -> tid) info) case loadedGraph of Left err -> return $ Left err Right freshGraph -> do @@ -148,7 +181,7 @@ if the transaction with the TransactionId argument is not yet part of the graph, then read the transaction and add it - this does not update the heads -} readTransactionIfNecessary :: FilePath -> TransactionId -> Maybe ScriptSession -> TransactionGraph -> IO (Either PersistenceError TransactionGraph) -readTransactionIfNecessary dbdir transId mScriptSession graphIn = do +readTransactionIfNecessary dbdir transId mScriptSession graphIn = if isRight $ transactionForId transId graphIn then --the transaction is already known and loaded- done return $ Right graphIn @@ -161,22 +194,29 @@ writeGraphTransactionIdFile :: DiskSync -> FilePath -> TransactionGraph -> IO LockFileHash writeGraphTransactionIdFile sync destDirectory (TransactionGraph _ transSet) = writeFileSync sync graphFile uuidInfo >> pure digest where - graphFile = destDirectory "m36v1" + graphFile = transactionLogPath destDirectory uuidInfo = T.intercalate "\n" graphLines digest = SHA256.hash (encodeUtf8 uuidInfo) graphLines = S.toList $ S.map graphLine transSet - graphLine trans = U.toText (transactionId trans) <> " " <> T.intercalate " " (S.toList (S.map U.toText $ transactionParentIds trans)) + epochTime = realToFrac . utcTimeToPOSIXSeconds . transactionTimestamp :: Transaction -> Double + graphLine trans = U.toText (transactionId trans) + <> " " + <> T.pack (show (epochTime trans)) + <> " " + <> T.intercalate " " (S.toList (S.map U.toText $ transactionParentIds trans)) readGraphTransactionIdFileDigest :: FilePath -> IO LockFileHash readGraphTransactionIdFileDigest dbdir = do graphTransactionIdData <- TIO.readFile (transactionLogPath dbdir) pure (SHA256.hash (encodeUtf8 graphTransactionIdData)) -readGraphTransactionIdFile :: FilePath -> IO (Either PersistenceError [(TransactionId, [TransactionId])]) +readGraphTransactionIdFile :: FilePath -> IO (Either PersistenceError [(TransactionId, UTCTime, [TransactionId])]) readGraphTransactionIdFile dbdir = do --read in all transactions' uuids - let grapher line = let tids = catMaybes (map U.fromText (T.words line)) in - (head tids, tail tids) + let grapher line = let tid:epochText:parentIds = T.words line in + (readUUID tid, readEpoch epochText, map readUUID parentIds) + readUUID uuidText = fromMaybe (error "failed to read uuid") (U.fromText uuidText) + readEpoch t = posixSecondsToUTCTime (realToFrac (either (error "failed to read epoch") fst (double t))) --warning: uses lazy IO graphTransactionIdData <- TIO.readFile (transactionLogPath dbdir) return $ Right (map grapher $ T.lines graphTransactionIdData) diff --git a/src/lib/ProjectM36/Tuple.hs b/src/lib/ProjectM36/Tuple.hs --- a/src/lib/ProjectM36/Tuple.hs +++ b/src/lib/ProjectM36/Tuple.hs @@ -11,6 +11,8 @@ import qualified Data.Vector as V import Data.Either (rights) import Control.Monad +import Control.Arrow +import Data.Maybe emptyTuple :: RelationTuple emptyTuple = RelationTuple V.empty V.empty @@ -25,7 +27,7 @@ tupleAttributes (RelationTuple tupAttrs _) = tupAttrs tupleAssocs :: RelationTuple -> [(AttributeName, Atom)] -tupleAssocs (RelationTuple attrVec tupVec) = V.toList $ V.map (\(k,v) -> (attributeName k, v)) (V.zip attrVec tupVec) +tupleAssocs (RelationTuple attrVec tupVec) = V.toList $ V.map (first attributeName) (V.zip attrVec tupVec) -- return atoms in some arbitrary but consistent key order tupleAtoms :: RelationTuple -> V.Vector Atom @@ -33,9 +35,9 @@ atomForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Atom atomForAttributeName attrName (RelationTuple tupAttrs tupVec) = case V.findIndex (\attr -> attributeName attr == attrName) tupAttrs of - Nothing -> Left $ NoSuchAttributeNamesError (S.singleton attrName) + Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName)) Just index -> case tupVec V.!? index of - Nothing -> Left $ NoSuchAttributeNamesError (S.singleton attrName) + Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName)) Just atom -> Right atom {- -- resolve naming clash with Attribute and Relation later @@ -56,11 +58,10 @@ else Right $ V.map mapper attrNameVec where - unknownAttrNames = V.filter ((flip V.notElem) (attributeNames attrs)) attrNameVec - mapper attrName = case V.elemIndex attrName (V.map attributeName attrs) of - Nothing -> error "logic failure in vectorIndicesForAttributeNames" - Just index -> index + unknownAttrNames = V.filter (`V.notElem` attributeNames attrs) attrNameVec + mapper attrName = fromMaybe (error "logic failure in vectorIndicesForAttributeNames") (V.elemIndex attrName (V.map attributeName attrs)) + relationForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Relation relationForAttributeName attrName tuple = do aType <- atomTypeForAttributeName attrName (tupleAttributes tuple) @@ -77,10 +78,10 @@ newAttrs = renameAttributes oldattr newattr tupAttrs mkRelationTuple :: Attributes -> V.Vector Atom -> RelationTuple -mkRelationTuple attrs atoms = RelationTuple attrs atoms +mkRelationTuple = RelationTuple mkRelationTuples :: Attributes -> [V.Vector Atom] -> [RelationTuple] -mkRelationTuples attrs atomsVec = map mapper atomsVec +mkRelationTuples attrs = map mapper where mapper = mkRelationTuple attrs @@ -92,7 +93,7 @@ --return error if attribute names match but their types do not singleTupleSetJoin :: Attributes -> RelationTuple -> RelationTupleSet -> Either RelationalError [RelationTuple] -singleTupleSetJoin joinAttrs tup tupSet = do +singleTupleSetJoin joinAttrs tup tupSet = foldM tupleJoiner [] (asList tupSet) where tupleJoiner :: [RelationTuple] -> RelationTuple -> Either RelationalError [RelationTuple] @@ -114,12 +115,12 @@ singleTupleJoin joinedAttrs tup1@(RelationTuple tupAttrs1 _) tup2@(RelationTuple tupAttrs2 _) = if V.null keysIntersection || atomsForAttributeNames keysIntersection tup1 /= atomsForAttributeNames keysIntersection tup2 then - return $ Nothing + return Nothing else return $ Just $ RelationTuple joinedAttrs newVec where keysIntersection = V.map attributeName attrsIntersection - attrsIntersection = V.filter (flip V.elem $ tupAttrs1) tupAttrs2 + attrsIntersection = V.filter (`V.elem` tupAttrs1) tupAttrs2 newVec = V.map (findAtomForAttributeName . attributeName) joinedAttrs --search both tuples for the attribute findAtomForAttributeName attrName = head $ rights $ fmap (atomForAttributeName attrName) [tup1, tup2] @@ -174,15 +175,15 @@ newTupVec = indexFilter (tupleAtoms tuple1) -- | An optimized form of tuple update which updates vectors efficiently. -updateTupleWithAtoms :: (M.Map AttributeName Atom) -> RelationTuple -> RelationTuple +updateTupleWithAtoms :: M.Map AttributeName Atom -> RelationTuple -> RelationTuple updateTupleWithAtoms updateMap (RelationTuple attrs tupVec) = RelationTuple attrs newVec where updateKeysSet = M.keysSet updateMap updateKeysIVec = V.filter (\(_,attr) -> S.member (attributeName attr) updateKeysSet) (V.indexed attrs) newVec = V.update tupVec updateVec - updateVec = V.map (\(index, attr) -> (index, updateMap M.! (attributeName attr))) updateKeysIVec + updateVec = V.map (\(index, attr) -> (index, updateMap M.! attributeName attr)) updateKeysIVec -tupleToMap :: RelationTuple -> (M.Map AttributeName Atom) +tupleToMap :: RelationTuple -> M.Map AttributeName Atom tupleToMap (RelationTuple attrs tupVec) = M.fromList assocList where assocList = V.toList $ V.map (\(index, attr) -> (attributeName attr, tupVec V.! index)) (V.indexed attrs) @@ -201,10 +202,13 @@ reorderTuple :: Attributes -> RelationTuple -> RelationTuple reorderTuple attrs tupIn = if tupleAttributes tupIn == attrs then tupIn - else do + else RelationTuple attrs (V.map mapper attrs) where mapper attr = case atomForAttributeName (attributeName attr) tupIn of Left _ -> error "logic failure in reorderTuple" Right atom -> atom +--used in Generics derivation for ADTs without named attributes +trimTuple :: Int -> RelationTuple -> RelationTuple +trimTuple index (RelationTuple attrs vals) = RelationTuple (V.drop index attrs) (V.drop index vals) diff --git a/src/lib/ProjectM36/TupleSet.hs b/src/lib/ProjectM36/TupleSet.hs --- a/src/lib/ProjectM36/TupleSet.hs +++ b/src/lib/ProjectM36/TupleSet.hs @@ -18,10 +18,10 @@ verifyTupleSet :: Attributes -> RelationTupleSet -> Either RelationalError RelationTupleSet verifyTupleSet attrs tupleSet = do --check that all tuples have the same attributes and that the atom types match - let tupleList = (map (verifyTuple attrs) (asList tupleSet)) `P.using` P.parListChunk chunkSize P.r0 - chunkSize = ((length . asList) tupleSet) `div` 24 + let tupleList = map (verifyTuple attrs) (asList tupleSet) `P.using` P.parListChunk chunkSize P.r0 + chunkSize = (length . asList) tupleSet `div` 24 --let tupleList = P.parMap P.rdeepseq (verifyTuple attrs) (HS.toList tupleSet) - if length (lefts tupleList) > 0 then + if not (null (lefts tupleList)) then Left $ head (lefts tupleList) else return $ RelationTupleSet $ (HS.toList . HS.fromList) (rights tupleList) @@ -30,4 +30,4 @@ mkTupleSet attrs tuples = verifyTupleSet attrs (RelationTupleSet tuples) mkTupleSetFromList :: Attributes -> [[Atom]] -> Either RelationalError RelationTupleSet -mkTupleSetFromList attrs atomMatrix = mkTupleSet attrs $ map (\atomList -> mkRelationTuple attrs (V.fromList atomList)) atomMatrix +mkTupleSetFromList attrs atomMatrix = mkTupleSet attrs $ map (mkRelationTuple attrs . V.fromList) atomMatrix diff --git a/src/lib/ProjectM36/Tupleable.hs b/src/lib/ProjectM36/Tupleable.hs new file mode 100644 --- /dev/null +++ b/src/lib/ProjectM36/Tupleable.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeOperators, UndecidableInstances, ScopedTypeVariables, DefaultSignatures #-} +module ProjectM36.Tupleable where +import ProjectM36.Base +import ProjectM36.Error +import ProjectM36.Tuple +import ProjectM36.TupleSet +import ProjectM36.Atomable +import ProjectM36.DataTypes.Primitive +import ProjectM36.Attribute hiding (null) +import GHC.Generics +import qualified Data.Vector as V +import qualified Data.Text as T +import Data.Monoid +import Data.Foldable + +{- +data Test1T = Test1C { + attrA :: Int + } + deriving (Generic, Show) + +data Test2T a b = Test2C { + attrB :: a, + attrC :: b + } + deriving (Generic, Show) + +instance (Atomable a, Atomable b, Show a, Show b) => Tupleable (Test2T a b) + +instance Tupleable Test1T + +data TestUnnamed1 = TestUnnamed1 Int Double T.Text + deriving (Show,Eq, Generic) + +instance Tupleable TestUnnamed1 +-} + +-- | Convert a 'Traverseable' of 'Tupleable's to an 'Insert' 'DatabaseContextExpr'. This is useful for converting, for example, a list of data values to a set of Insert expressions which can be used to add the values to the database. +toInsertExpr :: (Tupleable a, Traversable t) => t a -> RelVarName -> Either RelationalError DatabaseContextExpr +toInsertExpr vals rvName = do + let attrs = toAttributes (head (toList vals)) + tuples <- mkTupleSet attrs $ toList (fmap toTuple vals) + let rel = MakeStaticRelation attrs tuples + pure (Insert rvName rel) + +-- | Convert a 'Tupleable' to a create a 'Define' expression which can be used to create an empty relation variable. Use 'toInsertExpr' to insert the actual tuple data. This function is typically used with 'undefined'. +toDefineExpr :: Tupleable a => a -> RelVarName -> DatabaseContextExpr +toDefineExpr val rvName = Define rvName (map NakedAttributeExpr (V.toList attrs)) + where + attrs = toAttributes val + + + +class Tupleable a where + toTuple :: a -> RelationTuple + + fromTuple :: RelationTuple -> Either RelationalError a + + toAttributes :: a -> Attributes + + default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple + toTuple v = toTupleG (from v) + + default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> Either RelationalError a + fromTuple tup = to <$> fromTupleG tup + + default toAttributes :: (Generic a, TupleableG (Rep a)) => a -> Attributes + toAttributes v = toAttributesG (from v) + +class TupleableG g where + toTupleG :: g a -> RelationTuple + toAttributesG :: g a -> Attributes + fromTupleG :: RelationTuple -> Either RelationalError (g a) + +--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 + +--constructor metadata +instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) where + toTupleG (M1 v) = RelationTuple attrs atoms + where + attrsToCheck = toAttributesG 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 + +-- 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 (trimTuple 1 tup) + +--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) + where + name = T.pack (selName m) + aType = toAtomTypeG v + fromTupleG 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 + val <- atomv atom + pure (M1 val) + where + expectedAtomType = atomType (V.head (toAttributesG (undefined :: M1 S c a x))) + atomv atom = maybe (Left (AtomTypeMismatchError + expectedAtomType + (atomTypeForAtom atom) + )) Right (fromAtomG atom [atom]) + name = selName (undefined :: M1 S c a x) + +--constructors with no arguments +--basically useless but orthoganal to relationTrue +instance TupleableG U1 where + toTupleG _= emptyTuple + toAttributesG _ = emptyAttributes + fromTupleG _ = pure U1 + + diff --git a/src/lib/ProjectM36/Win32Handle.hs b/src/lib/ProjectM36/Win32Handle.hs --- a/src/lib/ProjectM36/Win32Handle.hs +++ b/src/lib/ProjectM36/Win32Handle.hs @@ -41,7 +41,7 @@ -- Get the FD from the algebraic data type #if __GLASGOW_HASKELL__ < 612 - fd <- fmap haFD $ readMVar write_handle_mvar + fd <- haFD <$> readMVar write_handle_mvar #else --readMVar write_handle_mvar >>= \(Handle__ { haDevice = dev }) -> print (typeOf dev) Just fd <- fmap (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev)) $ readMVar write_handle_mvar diff --git a/test/Client/Simple.hs b/test/Client/Simple.hs new file mode 100644 --- /dev/null +++ b/test/Client/Simple.hs @@ -0,0 +1,68 @@ +import ProjectM36.Client.Simple +import Test.HUnit +import System.Exit +import ProjectM36.Relation +import qualified ProjectM36.Client as C +import System.IO.Temp +import System.FilePath +import ProjectM36.TupleSet +import ProjectM36.Attribute +import ProjectM36.Error +import qualified Data.Vector as V + +main :: IO () +main = do + tcounts <- runTestTT testList + if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess + +testList :: Test +testList = TestList [testSimpleCommitSuccess, testSimpleCommitFailure] + +assertEither :: (Show a) => IO (Either a b) -> IO b +assertEither x = do + res <- x + case res of + Left err -> assertFailure (show err) >> undefined + Right val -> pure val + +testSimpleCommitSuccess :: Test +testSimpleCommitSuccess = TestCase $ + withSystemTempDirectory "m36tempdb" $ \tempdir -> do + let connInfo = InProcessConnectionInfo (MinimalPersistence (tempdir "db")) emptyNotificationCallback [] + relExpr = Union (RelationVariable "x" ()) (RelationVariable "y" ()) + + dbconn <- assertEither (simpleConnectProjectM36 connInfo) + Right rel <- withTransaction dbconn $ do + + execute (Assign "x" (ExistingRelation relationTrue)) + execute (Assign "y" (ExistingRelation relationFalse)) + query relExpr + + assertEqual "true/false simple" relationTrue rel + -- re-open with standard API and validate that the relvars are available + conn <- assertEither $ C.connectProjectM36 connInfo + + sess <- assertEither $ C.createSessionAtHead conn "master" + eRes <- C.executeRelationalExpr sess conn relExpr + assertEqual "x and y" (Right relationTrue) eRes + +testSimpleCommitFailure :: Test +testSimpleCommitFailure = TestCase $ do + let failAttrs = attributesFromList [Attribute "fail" IntAtomType] + err <- withSystemTempDirectory "m36tempdb" $ \tempdir -> do + let connInfo = InProcessConnectionInfo (MinimalPersistence (tempdir "db")) emptyNotificationCallback [] + dbconn <- assertEither (simpleConnectProjectM36 connInfo) + withTransaction dbconn $ do + execute $ Assign "x" (ExistingRelation relationTrue) + --cause error + execute $ Assign "x" (MakeStaticRelation failAttrs emptyTupleSet) + let expectedErr = Left (RelError (RelVarAssignmentTypeMismatchError V.empty failAttrs)) + assertEqual "dbc error" expectedErr err + + + + + + + + diff --git a/test/IsomorphicSchema.hs b/test/IsomorphicSchema.hs --- a/test/IsomorphicSchema.hs +++ b/test/IsomorphicSchema.hs @@ -65,8 +65,8 @@ testIsoRestrict = TestCase $ do -- create a emp relation which is restricted into two boss, nonboss rel vars -- the virtual schema has an employee - let empattrs = (A.attributesFromList [Attribute "name" TextAtomType, - Attribute "boss" TextAtomType]) + let empattrs = A.attributesFromList [Attribute "name" TextAtomType, + Attribute "boss" TextAtomType] emprel <- assertEither $ mkRelationFromList empattrs [[TextAtom "Steve", TextAtom ""], [TextAtom "Cindy", TextAtom "Steve"], diff --git a/test/MultiProcessDatabaseAccess.hs b/test/MultiProcessDatabaseAccess.hs --- a/test/MultiProcessDatabaseAccess.hs +++ b/test/MultiProcessDatabaseAccess.hs @@ -19,18 +19,11 @@ Left err -> assertFailure (show err) >> undefined Right val -> pure val -assertIONothing :: (Show a) => IO (Maybe a) -> IO () -assertIONothing x = do - ret <- x - case ret of - Nothing -> pure () - Just err -> assertFailure (show err) - testList :: Test testList = TestList [testMultipleProcessAccess] testMultipleProcessAccess :: Test -testMultipleProcessAccess = TestCase $ do +testMultipleProcessAccess = TestCase $ withSystemTempDirectory "pm36" $ \tmpdir -> do let connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback [] master = "master" @@ -38,16 +31,16 @@ dbdir = tmpdir "db" conn1 <- assertIOEither $ connectProjectM36 connInfo conn2 <- assertIOEither $ connectProjectM36 connInfo - session1 <- assertIOEither (createSessionAtHead master conn1) - session2 <- assertIOEither (createSessionAtHead master conn2) + session1 <- assertIOEither (createSessionAtHead conn1 master) + session2 <- assertIOEither (createSessionAtHead conn2 master) --add a commit on conn1 which conn2 doesn't know about - assertIONothing $ executeDatabaseContextExpr session1 conn1 dudExpr - assertIONothing $ commit session1 conn1 ForbidEmptyCommitOption + assertIOEither $ executeDatabaseContextExpr session1 conn1 dudExpr + assertIOEither $ commit session1 conn1 - assertIONothing $ executeDatabaseContextExpr session2 conn2 dudExpr - mHeadId <- headTransactionId session2 conn2 - headId <- case mHeadId of - Nothing -> assertFailure "headTransactionId failed" >> undefined - Just x -> pure x - res <- commit session2 conn2 ForbidEmptyCommitOption - assertEqual "commit should fail" (Just (TransactionIsNotAHeadError headId)) res + assertIOEither $ executeDatabaseContextExpr session2 conn2 dudExpr + eHeadId <- headTransactionId session2 conn2 + headId <- case eHeadId of + Left err -> assertFailure ("headTransactionId failed: " ++ show err) >> undefined + Right x -> pure x + res <- commit session2 conn2 + assertEqual "commit should fail" (Left (TransactionIsNotAHeadError headId)) res diff --git a/test/Relation/Atomable.hs b/test/Relation/Atomable.hs --- a/test/Relation/Atomable.hs +++ b/test/Relation/Atomable.hs @@ -13,6 +13,7 @@ import Data.Text import qualified Data.Map as M +{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-} data Test1T = Test1C Int deriving (Generic, Show, Eq, Binary, NFData, Atomable) @@ -60,7 +61,7 @@ testHaskell2DB = TestCase $ do --validate generated database context expression (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback - let test1TExpr = toDatabaseContextExpr (undefined :: Test1T) + let test1TExpr = toAddTypeExpr (undefined :: Test1T) expectedTest1TExpr = AddTypeConstructor (ADTypeConstructorDef "Test1T" []) [DataConstructorDef "Test1C" [DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Int" IntAtomType)]] assertEqual "simple ADT1" expectedTest1TExpr test1TExpr checkExecuteDatabaseContextExpr sessionId dbconn test1TExpr @@ -108,7 +109,7 @@ assertEqual "record-based ADT" example (fromAtom (toAtom example)) checkExecuteDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO () -checkExecuteDatabaseContextExpr sessionId dbconn expr = executeDatabaseContextExpr sessionId dbconn expr >>= maybe (pure ()) (\err -> assertFailure (show err)) +checkExecuteDatabaseContextExpr sessionId dbconn expr = executeDatabaseContextExpr sessionId dbconn expr >>= either (assertFailure . show) (const (pure ())) testListInstance :: Test testListInstance = TestCase $ do diff --git a/test/Relation/Basic.hs b/test/Relation/Basic.hs --- a/test/Relation/Basic.hs +++ b/test/Relation/Basic.hs @@ -50,7 +50,7 @@ validateAttrTypesMatchTupleAttrTypes :: Relation -> Either RelationalError Relation validateAttrTypesMatchTupleAttrTypes rel@(Relation attrs tupSet) = foldr (\tuple acc -> - if (tupleAttributes tuple) == attrs && tupleAtomCheck tuple then + if tupleAttributes tuple == attrs && tupleAtomCheck tuple then acc else Left $ TupleAttributeTypeMismatchError A.emptyAttributes diff --git a/test/Relation/Export/CSV.hs b/test/Relation/Export/CSV.hs --- a/test/Relation/Export/CSV.hs +++ b/test/Relation/Export/CSV.hs @@ -22,11 +22,11 @@ [TextAtom "S9", TextAtom "Perry", IntAtom 170, TextAtom "Londonderry"], [TextAtom "S8", TextAtom "Mike", IntAtom 150, TextAtom "Boston"]] case relOrErr of - Left err -> assertFailure $ "export relation creation failure: " ++ (show err) - Right rel -> do + Left err -> assertFailure $ "export relation creation failure: " ++ show err + Right rel -> case relationAsCSV rel of - Left err -> assertFailure $ "export failed: " ++ (show err) + Left err -> assertFailure $ "export failed: " ++ show err Right csvData -> case csvAsRelation csvData attrs of -- import csv data back to relation - Left err -> assertFailure $ "re-import failed: " ++ (show err) + Left err -> assertFailure $ "re-import failed: " ++ show err Right rel' -> assertEqual "relation CSV comparison" rel rel' diff --git a/test/Relation/Tupleable.hs b/test/Relation/Tupleable.hs new file mode 100644 --- /dev/null +++ b/test/Relation/Tupleable.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE DeriveGeneric, FlexibleInstances, FlexibleContexts, TypeOperators, DeriveAnyClass #-} +import Test.HUnit +import ProjectM36.Tupleable +import ProjectM36.Atomable +import ProjectM36.Attribute +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 +import System.Exit + +{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-} + +data Test1T = Test1C { + attrA :: Int + } + deriving (Generic, Eq, Show) + +data Test2T = Test2C { + attrB :: Int, + attrC :: Int + } + deriving (Generic, Eq, Show) + +data Test3T = Test3C Int + deriving (Generic, Eq, Show) + +data Test4T = Test4C + deriving (Generic, Eq, Show) + +data Test5T = Test5C1 Int | + Test5C2 Int + deriving (Generic, Eq, Show) + +data Test6T = Test6C T.Text Int Double + deriving (Generic, Eq, Show) + +data Test7A = Test7AC Int + deriving (Generic, Show, Eq, Binary, NFData, Atomable) + + +data Test7T = Test7C Test7A + deriving (Generic, Show, Eq) + +data Test8T = Test8C + deriving (Generic, Show, Eq) + +instance Tupleable Test1T + +instance Tupleable Test2T + +instance Tupleable Test3T + +instance Tupleable Test4T + +--instance Tupleable Test5T -- should fail at compile time- sum types not supported + +instance Tupleable Test6T + +instance Tupleable Test7T + +instance Tupleable Test8T + +main :: IO () +main = do + tcounts <- runTestTT testList + if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess + +testList :: Test +testList = TestList [testADT1, testADT2, testADT3, testADT4, testADT6, testADT7, testADT8] + +testADT1 :: Test +testADT1 = TestCase $ assertEqual "one record constructor" (Right example) (fromTuple (toTuple example)) + where + example = Test1C {attrA = 3} + + +testADT2 :: Test +testADT2 = TestCase $ do + let example = Test2C { attrB = 4, attrC = 6 } + assertEqual "two record constructor" (Right example) (fromTuple (toTuple example)) + --this was a tricky case that was throwing the undefined exception because of insufficient laziness in the :*: matching- see ProjectM36.Tupleable + let expectedAttributes = attributesFromList [Attribute "attrB" IntAtomType, + Attribute "attrC" IntAtomType] + assertEqual "two record constructor toAttributes" expectedAttributes (toAttributes (undefined :: Test2T)) + + +testADT3 :: Test +testADT3 = TestCase $ assertEqual "one arg constructor" (Right example) (fromTuple (toTuple example)) + where + example = Test3C 4 + +testADT4 :: Test +testADT4 = TestCase $ assertEqual "zero arg constructor" (Right example) (fromTuple (toTuple example)) + where + example = Test4C + +--testADT5 should not compile + +testADT6 :: Test +testADT6 = TestCase $ assertEqual "mixed types" (Right example) (fromTuple (toTuple example)) + where + example = Test6C "testo" 3 4.0 + +testADT7 :: Test +testADT7 = TestCase $ do + let example = Test7C (Test7AC 3) + assertEqual "atom type" (Right example) (fromTuple (toTuple example)) + let expectedAttrs = V.singleton (Attribute "" (ConstructedAtomType "Test7A" M.empty)) + assertEqual "adt atomtype" expectedAttrs (toAttributes (undefined :: Test7T)) + +testADT8 :: Test +testADT8 = TestCase $ assertEqual "single value" (Right example) (fromTuple (toTuple example)) + where + example = Test8C diff --git a/test/Server/Main.hs b/test/Server/Main.hs --- a/test/Server/Main.hs +++ b/test/Server/Main.hs @@ -19,7 +19,6 @@ import Network.Transport (EndPointAddress) import Network.Transport.TCP (encodeEndPointAddress, decodeEndPointAddress) import Data.Either (isRight) -import Data.Maybe (isJust) import Control.Exception --import Control.Monad.IO.Class #if defined(linux_HOST_OS) @@ -51,7 +50,7 @@ notificationTestMVar <- newEmptyMVar eTestConn <- testConnection serverAddress notificationTestMVar case eTestConn of - Left err -> putStrLn (show err) >> exitFailure + Left err -> print err >> exitFailure Right (session, testConn) -> do tcounts <- runTestTT (testList session testConn notificationTestMVar) if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess @@ -73,7 +72,7 @@ case eConn of Left err -> pure $ Left err Right conn -> do - eSessionId <- createSessionAtHead defaultHeadName conn + eSessionId <- createSessionAtHead conn defaultHeadName case eSessionId of Left _ -> error "failed to create session" Right sessionId -> pure $ Right (sessionId, conn) @@ -97,35 +96,32 @@ relResult <- executeRelationalExpr sessionId conn (RelationVariable "true" ()) assertEqual "invalid relation result" (Right relationTrue) relResult +eitherFail :: (Show e) => Either e a -> IO () +eitherFail (Left err) = assertFailure (show err) +eitherFail (Right _) = pure () + -- test adding an removing a schema against true/false relations testSchemaExpr :: SessionId -> Connection -> Test testSchemaExpr sessionId conn = TestCase $ do result <- executeSchemaExpr sessionId conn (AddSubschema "test-schema" [IsoRename "table_dee" "true", IsoRename "table_dum" "false"]) - assertEqual "executeSchemaExpr" Nothing result + assertEqual "executeSchemaExpr" (Right ()) result result' <- executeSchemaExpr sessionId conn (RemoveSubschema "test-schema") - assertEqual "executeSchemaExpr2" Nothing result' + assertEqual "executeSchemaExpr2" (Right ()) result' testDatabaseContextExpr :: SessionId -> Connection -> Test testDatabaseContextExpr sessionId conn = TestCase $ do let attrExprs = [AttributeAndTypeNameExpr "x" (PrimitiveTypeConstructor "Text" TextAtomType) ()] attrs = attributesFromList [Attribute "x" TextAtomType] testrv = "testrv" - dbResult <- executeDatabaseContextExpr sessionId conn (Define testrv attrExprs) - case dbResult of - Just err -> assertFailure (show err) - Nothing -> do - eRel <- executeRelationalExpr sessionId conn (RelationVariable testrv ()) - let expected = mkRelation attrs emptyTupleSet - case eRel of - Left err -> assertFailure (show err) - Right rel -> assertEqual "dbcontext definition failed" expected (Right rel) + executeDatabaseContextExpr sessionId conn (Define testrv attrExprs) >>= eitherFail + eRel <- executeRelationalExpr sessionId conn (RelationVariable testrv ()) + let expected = mkRelation attrs emptyTupleSet + case eRel of + Left err -> assertFailure (show err) + Right rel -> assertEqual "dbcontext definition failed" expected (Right rel) testGraphExpr :: SessionId -> Connection -> Test -testGraphExpr sessionId conn = TestCase $ do - graphResult <- executeGraphExpr sessionId conn (JumpToHead "master") - case graphResult of - Just err -> assertFailure (show err) - Nothing -> pure () +testGraphExpr sessionId conn = TestCase (executeGraphExpr sessionId conn (JumpToHead "master") >>= eitherFail) testTypeForRelationalExpr :: SessionId -> Connection -> Test testTypeForRelationalExpr sessionId conn = TestCase $ do @@ -154,13 +150,13 @@ testHeadTransactionId :: SessionId -> Connection -> Test testHeadTransactionId sessionId conn = TestCase $ do uuid <- headTransactionId sessionId conn - assertBool "invalid head transaction uuid" (isJust uuid) + assertBool "invalid head transaction uuid" (isRight uuid) pure () testHeadName :: SessionId -> Connection -> Test testHeadName sessionId conn = TestCase $ do - mHeadName <- headName sessionId conn - assertEqual "headName failure" (Just "master") mHeadName + eHeadName <- headName sessionId conn + assertEqual "headName failure" (Right "master") eHeadName testRelationVariableSummary :: SessionId -> Connection -> Test testRelationVariableSummary sessionId conn = TestCase $ do @@ -172,15 +168,15 @@ testSession :: SessionId -> Connection -> Test testSession _ conn = TestCase $ do -- create and close a new session using AtHead and AtCommit - eSessionId1 <- createSessionAtHead defaultHeadName conn + eSessionId1 <- createSessionAtHead conn defaultHeadName case eSessionId1 of Left _ -> assertFailure "invalid session" Right sessionId1 -> do - mHeadId <- headTransactionId sessionId1 conn - case mHeadId of - Nothing -> assertFailure "invalid head id" - Just headId -> do - eSessionId2 <- createSessionAtCommit headId conn + eHeadId <- headTransactionId sessionId1 conn + case eHeadId of + Left err -> assertFailure ("invalid head id: " ++ show err) + Right headId -> do + eSessionId2 <- createSessionAtCommit conn headId assertBool ("invalid session: " ++ show eSessionId2) (isRight eSessionId2) closeSession sessionId1 conn @@ -191,12 +187,11 @@ testNotification :: MVar () -> SessionId -> Connection -> Test testNotification mvar sess conn = TestCase $ do let relvarx = RelationVariable "x" () - check x = x >>= maybe (pure ()) (\err -> assertFailure (show err)) - check $ executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue)) - check $ executeDatabaseContextExpr sess conn (AddNotification "test notification" relvarx relvarx) - check $ commit sess conn ForbidEmptyCommitOption - check $ executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationFalse)) - check $ commit sess conn ForbidEmptyCommitOption + executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue)) >>= eitherFail + executeDatabaseContextExpr sess conn (AddNotification "test notification" relvarx relvarx) >>= eitherFail + commit sess conn >>= eitherFail + executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationFalse)) >>= eitherFail + commit sess conn >>= eitherFail takeMVar mvar testRequestTimeout :: Test diff --git a/test/Server/WebSocket.hs b/test/Server/WebSocket.hs --- a/test/Server/WebSocket.hs +++ b/test/Server/WebSocket.hs @@ -1,5 +1,4 @@ -- test the websocket server - import Test.HUnit import qualified Network.WebSockets as WS import ProjectM36.Server.WebSocket @@ -46,14 +45,14 @@ instance Exception TestException waitForListenSocket :: Int -> PortNumber -> IO () -waitForListenSocket secondsToTry port = do +waitForListenSocket secondsToTry port = if secondsToTry <= 0 then throw WaitForSocketListenException else do hostaddr <- inet_addr "127.0.0.1" sock <- socket AF_INET Stream defaultProtocol let handler :: IOException -> IO () - handler = \_ -> do + handler _ = do threadDelay 1000000 waitForListenSocket (secondsToTry - 1) port catch (connect sock (SockAddrInet port hostaddr)) handler @@ -69,11 +68,11 @@ testTutorialD] basicConnection :: PortNumber -> WS.ClientApp () -> IO () -basicConnection port block = WS.runClient "127.0.0.1" (fromIntegral port) "/" block +basicConnection port = WS.runClient "127.0.0.1" (fromIntegral port) "/" basicConnectionWithDatabase :: PortNumber -> DatabaseName -> WS.ClientApp () -> IO () basicConnectionWithDatabase port dbname block = basicConnection port (\conn -> do - WS.sendTextData conn ("connectdb:" `append` (pack dbname)) + WS.sendTextData conn ("connectdb:" `append` pack dbname) block conn) testBasicConnection :: PortNumber -> DatabaseName -> Test diff --git a/test/TransactionGraph/Automerge.hs b/test/TransactionGraph/Automerge.hs new file mode 100644 --- /dev/null +++ b/test/TransactionGraph/Automerge.hs @@ -0,0 +1,95 @@ +import Test.HUnit +import ProjectM36.Client +import ProjectM36.Relation +import ProjectM36.Error +import qualified Data.Set as S +import TutorialD.Interpreter.TestBase + +import System.Exit +import System.IO.Temp +import System.FilePath +import Control.Exception.Base + +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} +main :: IO () +main = do + tcounts <- runTestTT testList + if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess + +testList :: Test +testList = TestList [testAutomergeSuccess, + testAutomergeFailure, + testAutomergeReconnect] + +checkEither :: IO (Either RelationalError a) -> IO a +checkEither io = do + ret <- io + case ret of + Left err -> assertFailure (show err) >> undefined + Right a -> pure a + +testAutomergeSuccess :: Test +testAutomergeSuccess = TestCase $ do + --create two sessions, diverge from the head, and automerge back + (sessionId, conn) <- dateExamplesConnection emptyNotificationCallback + let headn = "master" + sessionPastId <- checkEither $ createSessionAtHead conn headn + executeTutorialD sessionId conn "insert s relation{tuple{city \"New City\", s# \"S6\", sname \"Samuels\", status 50}}" + checkEither $ commit sessionId conn + + executeTutorialD sessionPastId conn "insert s relation{tuple{city \"Merge City\", s# \"S7\", sname \"Mr. Merge\", status 60}}" + + checkEither $ autoMergeToHead sessionPastId conn UnionMergeStrategy headn + + --validate that both tuples are now in the head transaction + + let predi = eqAttr + eqAttr key = AttributeEqualityPredicate "s#" (NakedAtomExpr (TextAtom key)) + result <- checkEither $ executeRelationalExpr sessionPastId conn (Project (AttributeNames S.empty) (Restrict (predi "S6") (RelationVariable "s" ()))) + assertEqual "new S6" relationTrue result + + result' <- checkEither $ executeRelationalExpr sessionPastId conn (Project (AttributeNames S.empty) (Restrict (predi "S7") (RelationVariable "s" ()))) + + assertEqual "new S7" relationTrue result' + + eHeadName <- headName sessionPastId conn + assertEqual "back on master" (Right "master") eHeadName + +testAutomergeFailure :: Test +testAutomergeFailure = TestCase $ do + --create two sessions, diverge from the head, but create a union merge strategy failure + (sessionId, conn) <- dateExamplesConnection emptyNotificationCallback + let headn = "master" + sessionPastId <- checkEither $ createSessionAtHead conn headn + executeTutorialD sessionId conn "insert s relation{tuple{city \"New City\", s# \"S6\", sname \"Samuels\", status 50}}" + checkEither $ commit sessionId conn + + --reuse the same id, violating the uniqueness constraint + executeTutorialD sessionPastId conn "insert s relation{tuple{city \"Merge City\", s# \"S6\", sname \"Mr. Merge\", status 60}}" + + --validate that both tuples are now in the head transaction + --should fail + mergeRes <- autoMergeToHead sessionPastId conn UnionMergeStrategy headn + + _ <- checkEither $ executeRelationalExpr sessionPastId conn (RelationVariable "s" ()) + + assertEqual "merge failure" (Left (InclusionDependencyCheckError "s_pkey")) mergeRes + +--reported as #128 +testAutomergeReconnect :: Test +testAutomergeReconnect = TestCase $ withSystemTempDirectory "m36testdb" $ \tempdir -> do + let repro = do + conn <- unsafeLeftCrash =<< connectProjectM36 (InProcessConnectionInfo (CrashSafePersistence (tempdir "test.db")) emptyNotificationCallback []) + sess <- unsafeLeftCrash =<< createSessionAtHead conn "master" + autoMergeToHead sess conn UnionMergeStrategy "master" + -- commit sess conn + + unsafeLeftCrash :: Show e => Either e a -> IO a + unsafeLeftCrash = either (throwIO . userError . show) pure + _ <- repro + _ <- repro + pure () + + + + diff --git a/test/TransactionGraph/Merge.hs b/test/TransactionGraph/Merge.hs --- a/test/TransactionGraph/Merge.hs +++ b/test/TransactionGraph/Merge.hs @@ -6,17 +6,28 @@ import ProjectM36.Transaction import ProjectM36.TransactionGraph import ProjectM36.Error +import ProjectM36.Key +import qualified ProjectM36.DisconnectedTransaction as Discon +import qualified ProjectM36.DatabaseContext as DBC +import ProjectM36.RelationalExpression + import qualified Data.ByteString.Lazy as BS import System.Exit import Data.Word -import ProjectM36.RelationalExpression -import qualified ProjectM36.DisconnectedTransaction as Discon import qualified Data.UUID as U import qualified Data.Set as S import qualified Data.Map as M -import qualified ProjectM36.DatabaseContext as DBC +import Data.Maybe +import Data.Time.Clock +import Data.Time.Calendar + import Control.Monad.State hiding (join) +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +testTime :: UTCTime +testTime = UTCTime (fromGregorian 1980 01 01) (secondsToDiffTime 1000) + main :: IO () main = do tcounts <- runTestTT testList @@ -29,7 +40,8 @@ testSubGraphToFirstAncestorMoreTransactions, testSelectedBranchMerge, testUnionMergeStrategy, - testUnionPreferMergeStrategy + testUnionPreferMergeStrategy, + testUnionMergeIncDepViolation ] -- | Create a transaction graph with two branches and no changes between them. @@ -44,16 +56,14 @@ basicTransactionGraph :: IO TransactionGraph basicTransactionGraph = do - let bsGraph = bootstrapTransactionGraph uuidRoot DBC.empty --dateExamples - rootTrans = case transactionForHead "master" bsGraph of - Just trans -> trans - Nothing -> error "bonk" + let bsGraph = bootstrapTransactionGraph testTime uuidRoot DBC.basicDatabaseContext + rootTrans = fromMaybe (error "bonk") (transactionForHead "master" bsGraph) uuidA = fakeUUID 10 uuidB = fakeUUID 11 uuidRoot = fakeUUID 1 rootContext = concreteDatabaseContext rootTrans - (_, bsGraph') <- addTransaction "branchA" (createTrans uuidA (TransactionInfo uuidRoot S.empty) rootContext) bsGraph - (_, bsGraph'') <- addTransaction "branchB" (createTrans uuidB (TransactionInfo uuidRoot S.empty) rootContext) bsGraph' + (_, bsGraph') <- addTransaction "branchA" (createTrans uuidA (TransactionInfo uuidRoot S.empty testTime) rootContext) bsGraph + (_, bsGraph'') <- addTransaction "branchB" (createTrans uuidB (TransactionInfo uuidRoot S.empty testTime) rootContext) bsGraph' pure bsGraph'' addTransaction :: HeadName -> Transaction -> TransactionGraph -> IO (Transaction, TransactionGraph) @@ -62,9 +72,7 @@ Right (t,g) -> pure (t,g) fakeUUID :: Word8 -> TransactionId -fakeUUID x = case U.fromByteString (BS.concat (replicate 4 w32)) of - Nothing -> error "impossible uuid" - Just u -> u +fakeUUID x = fromMaybe (error "impossible uuid") (U.fromByteString (BS.concat (replicate 4 w32))) where w32 = BS.pack (replicate 4 x) assertEither :: (Show a) => Either a b -> IO b @@ -99,7 +107,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) S.empty) (concreteDatabaseContext transA)) baseGraph + (_, graph) <- addTransaction "branchC" (createTrans (fakeUUID 12) (TransactionInfo (fakeUUID 1) S.empty testTime) (concreteDatabaseContext transA)) baseGraph subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph (transactionHeadsForGraph baseGraph) transA transB S.empty assertGraph subgraph let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg) @@ -111,23 +119,23 @@ graph <- basicTransactionGraph assertGraph graph - -- add another relvar to branchB +-- add another relvar to branchB branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head" (updatedBranchBContext,_,_) <- case runState (evalDatabaseContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (freshDatabaseState (concreteDatabaseContext branchBTrans)) of (Just err, _) -> assertFailure (show err) >> undefined (Nothing, context) -> pure context - (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty) updatedBranchBContext) graph + (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty 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) S.empty) (concreteDatabaseContext branchATrans)) graph' + (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty testTime) (concreteDatabaseContext branchATrans)) graph' branchATrans' <- assertMaybe (transactionForHead "branchA" graph'') "failed to get branchA head" assertEqual "branchA id 4" (fakeUUID 4) (transactionId branchATrans') --retrieve subgraph - let subGraphHeads = M.filter (\t -> elem (transactionId t) [fakeUUID 3, fakeUUID 4]) (transactionHeadsForGraph graph'') + let subGraphHeads = M.filter (\t -> transactionId t `elem` [fakeUUID 3, fakeUUID 4]) (transactionHeadsForGraph graph'') subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph'' subGraphHeads branchATrans' branchBTrans' S.empty --verify that the subgraph includes both the heads and the common ancestor let expectedTransSet = S.fromList (map fakeUUID [1,3,4]) @@ -143,9 +151,9 @@ (updatedBranchBContext,_,_) <- case runState (evalDatabaseContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (freshDatabaseState (concreteDatabaseContext branchBTrans)) of (Just err, _) -> assertFailure (show err) >> undefined (Nothing, context) -> pure context - (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty) updatedBranchBContext) graph + (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) updatedBranchBContext) graph --create the merge transaction in the graph - let eGraph' = mergeTransactions (fakeUUID 4) (fakeUUID 10) (SelectedBranchMergeStrategy "branchA") ("branchA", "branchB") graph' + let eGraph' = mergeTransactions testTime (fakeUUID 4) (fakeUUID 10) (SelectedBranchMergeStrategy "branchA") ("branchA", "branchB") graph' (_, graph'') <- assertEither eGraph' @@ -171,13 +179,13 @@ branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert conflictRelVarName branchBRelVar (relationVariables (concreteDatabaseContext branchBTrans))} conflictRelVarName = "conflictRelVar" - (_, graph') <- addTransaction "branchA" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchATrans) S.empty) branchAContext) graph - (_, graph'') <- addTransaction "branchB" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchBTrans) S.empty) branchBContext) graph' + (_, graph') <- addTransaction "branchA" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchATrans) S.empty testTime) branchAContext) graph + (_, graph'') <- addTransaction "branchB" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchBTrans) S.empty testTime) branchBContext) graph' -- validate that the conflict is hidden because we preferred a branch - let merged = mergeTransactions (fakeUUID 5) (fakeUUID 3) (UnionPreferMergeStrategy "branchB") ("branchA", "branchB") graph'' + let merged = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) (UnionPreferMergeStrategy "branchB") ("branchA", "branchB") graph'' case merged of Left err -> assertFailure ("expected merge success: " ++ show err) - Right (discon, _) -> do + Right (discon, _) -> assertEqual "branchB relvar preferred in conflict" (Just branchBRelVar) (M.lookup conflictRelVarName (relationVariables (Discon.concreteDatabaseContext discon))) -- try various individual component conflicts and check for merge failure @@ -197,11 +205,11 @@ branchAOnlyIncDepName = "branchAOnlyIncDep" branchBOnlyRelVarName = "branchBOnlyRelVar" branchAOnlyIncDep = InclusionDependency (ExistingRelation relationTrue) (ExistingRelation relationTrue) - (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty) updatedBranchBContext) graph - (discon, _) <- assertEither $ mergeTransactions (fakeUUID 5) (fakeUUID 10) UnionMergeStrategy ("branchA", "branchB") graph' + (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) updatedBranchBContext) graph + (discon, _) <- assertEither $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 10) UnionMergeStrategy ("branchA", "branchB") graph' assertEqual "branchBOnlyRelVar should appear in the merge" (M.lookup branchBOnlyRelVarName (relationVariables (Discon.concreteDatabaseContext discon))) (Just relationTrue) - (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty) updatedBranchAContext) graph' - let eMergeGraph = mergeTransactions (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph'' + (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty testTime) updatedBranchAContext) graph' + let eMergeGraph = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph'' case eMergeGraph of Left err -> assertFailure ("expected merge success: " ++ show err) Right (_, mergeGraph) -> do @@ -216,8 +224,42 @@ conflictRelVar <- assertEither $ mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) [] let conflictContextA = updatedBranchAContext {relationVariables = M.insert branchBOnlyRelVarName conflictRelVar (relationVariables updatedBranchAContext) } conflictBranchATrans <- assertMaybe (transactionForHead "branchA" graph'') "retrieving head transaction for expected conflict" - (_, graph''') <- addTransaction "branchA" (createTrans (fakeUUID 6) (TransactionInfo (transactionId conflictBranchATrans) S.empty) conflictContextA) graph'' - let failingMerge = mergeTransactions (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph''' + (_, graph''') <- addTransaction "branchA" (createTrans (fakeUUID 6) (TransactionInfo (transactionId conflictBranchATrans) S.empty testTime) conflictContextA) graph'' + let failingMerge = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph''' case failingMerge of Right _ -> assertFailure "expected merge failure" Left err -> assertEqual "merge failure" err (MergeTransactionError StrategyViolatesRelationVariableMergeError) + +-- test that a merge will fail if a constraint is violated +testUnionMergeIncDepViolation :: Test +testUnionMergeIncDepViolation = TestCase $ do + graph <- basicTransactionGraph + assertGraph graph + + branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head" + branchATrans <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA head" + + --add relvar and key constraint to both branches + let eRel val = mkRelationFromList (attributesFromList [Attribute "x" IntAtomType, Attribute "y" IntAtomType]) [[IntAtom 1, IntAtom val]] + rvName = "x" + Right branchArv = eRel 2 + Right branchBrv = eRel 3 + branchAContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.singleton rvName branchArv} + branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.singleton rvName branchBrv, + inclusionDependencies = M.singleton incDepName incDep} + incDepName = "x_key" + incDep = inclusionDependencyForKey (AttributeNames (S.singleton "x")) (RelationVariable "x" ()) + + + --add the rv in new commits to both branches + (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) branchBContext) graph + + (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty testTime) branchAContext) graph' + + --check that the union merge fails due to a violated constraint + let eMerge = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph'' + case eMerge of + Left (InclusionDependencyCheckError incDepName') -> assertEqual "incdep violation name" incDepName incDepName' + Left err -> assertFailure ("other error: " ++ show err) + Right _ -> assertFailure "constraint violation missing" + diff --git a/test/TransactionGraph/Persist.hs b/test/TransactionGraph/Persist.hs --- a/test/TransactionGraph/Persist.hs +++ b/test/TransactionGraph/Persist.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} import Test.HUnit import ProjectM36.Base import ProjectM36.Persist (DiskSync(NoDiskSync)) @@ -16,6 +15,8 @@ import TutorialD.Interpreter.DatabaseContextExpr import qualified Data.Map as M import qualified Data.Set as S +import Data.Time.Clock +import Data.Time.Calendar main :: IO () main = do @@ -27,12 +28,16 @@ testDBSimplePersistence, testFunctionPersistence] +stamp :: UTCTime +stamp = UTCTime (fromGregorian 1980 01 01) (secondsToDiffTime 1000) + {- bootstrap a database, ensure that it can be read -} testBootstrapDB :: Test testBootstrapDB = TestCase $ withSystemTempDirectory "m36testdb" $ \tempdir -> do let dbdir = tempdir "dbdir" freshId <- nextRandom - _ <- bootstrapDatabaseDir NoDiskSync dbdir (bootstrapTransactionGraph freshId dateExamples) + + _ <- bootstrapDatabaseDir NoDiskSync dbdir (bootstrapTransactionGraph stamp freshId dateExamples) loadedGraph <- transactionGraphLoad dbdir emptyTransactionGraph Nothing assertBool "transactionGraphLoad" $ isRight loadedGraph @@ -41,23 +46,24 @@ testDBSimplePersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \tempdir -> do let dbdir = tempdir "dbdir" freshId <- nextRandom - let graph = bootstrapTransactionGraph freshId dateExamples + + let graph = bootstrapTransactionGraph stamp freshId dateExamples _ <- bootstrapDatabaseDir NoDiskSync dbdir graph case transactionForHead "master" graph of Nothing -> assertFailure "Failed to retrieve head transaction for master branch." - Just headTrans -> do + Just headTrans -> case interpretDatabaseContextExpr (concreteDatabaseContext headTrans) "x:=s" of Left err -> assertFailure (show err) Right context' -> do freshId' <- nextRandom let newdiscon = DisconnectedTransaction (transactionId headTrans) (Schemas context' M.empty) True - addTrans = addDisconnectedTransaction freshId' "master" newdiscon graph + addTrans = addDisconnectedTransaction stamp freshId' "master" newdiscon graph --add a transaction to the graph case addTrans of Left err -> assertFailure (show err) Right (_, graph') -> do --persist the new graph - _ <- transactionGraphPersist NoDiskSync dbdir graph' + _ <- transactionGraphPersist NoDiskSync dbdir [freshId'] graph' --reload the graph from the filesystem and confirm that the transaction is present graphErr <- transactionGraphLoad dbdir emptyTransactionGraph Nothing let mapEq graphArg = S.map transactionId (transactionsForGraph graphArg) @@ -72,18 +78,18 @@ let dbdir = tempdir "dbdir" connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback [] Right conn <- connectProjectM36 connInfo - Right sess <- createSessionAtHead "master" conn + Right sess <- createSessionAtHead conn "master" let intTCons = PrimitiveTypeConstructor "Int" IntAtomType addfunc = AddAtomFunction "testdisk" [ intTCons, ADTypeConstructor "Either" [ADTypeConstructor "AtomFunctionError" [], intTCons]] "(\\(x:_) -> pure x) :: [Atom] -> Either AtomFunctionError Atom" - Nothing <- executeDatabaseContextIOExpr sess conn addfunc - Nothing <- commit sess conn ForbidEmptyCommitOption + Right () <- executeDatabaseContextIOExpr sess conn addfunc + Right () <- commit sess conn close conn --re-open the connection to reload the graph Right conn2 <- connectProjectM36 connInfo - Right sess2 <- createSessionAtHead "master" conn2 + Right sess2 <- createSessionAtHead conn2 "master" res <- executeRelationalExpr sess2 conn2 (MakeRelationFromExprs Nothing [TupleExpr (M.singleton "a" (FunctionAtomExpr "testdisk" [NakedAtomExpr (IntAtom 3)] ()))]) let expectedRel = mkRelationFromList (attributesFromList [Attribute "a" IntAtomType]) [[IntAtom 3]] diff --git a/test/TutorialD/Interpreter.hs b/test/TutorialD/Interpreter.hs --- a/test/TutorialD/Interpreter.hs +++ b/test/TutorialD/Interpreter.hs @@ -15,6 +15,7 @@ import ProjectM36.TransactionGraph import ProjectM36.Client import qualified ProjectM36.DisconnectedTransaction as Discon +import qualified ProjectM36.AttributeNames as AN import qualified ProjectM36.Session as Sess import qualified ProjectM36.Attribute as A import qualified Data.Map as M @@ -26,14 +27,15 @@ import qualified Data.Set as S import Data.Text hiding (map) import qualified Data.Text as T -import Data.Time.Clock.POSIX +import Data.Time.Clock.POSIX hiding (getCurrentTime) +import Data.Time.Clock (getCurrentTime) main :: IO () main = do tcounts <- runTestTT (TestList tests) if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess where - tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [transactionGraphBasicTest, transactionGraphAddCommitTest, transactionRollbackTest, transactionJumpTest, transactionBranchTest, simpleJoinTest, testNotification, testTypeConstructors, testMergeTransactions, testComments, testTransGraphRelationalExpr, failJoinTest, testMultiAttributeRename, testSchemaExpr, testRelationalExprStateTupleElems, testFunctionalDependencies, testEmptyCommits] + tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [transactionGraphBasicTest, transactionGraphAddCommitTest, transactionRollbackTest, transactionJumpTest, transactionBranchTest, simpleJoinTest, testNotification, testTypeConstructors, testMergeTransactions, testComments, testTransGraphRelationalExpr, failJoinTest, testMultiAttributeRename, testSchemaExpr, testRelationalExprStateTupleElems, testFunctionalDependencies, testEmptyCommits,testIntervalAtom] simpleRelTests = [("x:=true", Right relationTrue), ("x:=false", Right relationFalse), ("x:=true union false", Right relationTrue), @@ -43,7 +45,7 @@ ("x:=relation{a Int}{}", mkRelation simpleAAttributes emptyTupleSet), ("x:=relation{c Int}{} rename {c as d}", mkRelation simpleBAttributes emptyTupleSet), ("y:=relation{b Int, c Int}{}; x:=y{c}", mkRelation simpleProjectionAttributes emptyTupleSet), - ("x:=relation{tuple{a \"spam\", b 5}}", mkRelation simpleCAttributes $ RelationTupleSet [(RelationTuple simpleCAttributes) (V.fromList [TextAtom "spam", IntAtom 5])]), + ("x:=relation{tuple{a \"spam\", b 5}}", mkRelation simpleCAttributes $ RelationTupleSet [RelationTuple simpleCAttributes (V.fromList [TextAtom "spam", IntAtom 5])]), ("constraint failc true in false; x:=true", Left $ InclusionDependencyCheckError "failc"), ("x:=y; x:=true", Left $ RelVarNotDefinedError "y"), ("x:=relation{}{}", Right relationFalse), @@ -86,10 +88,10 @@ statusAtom <- atomForAttributeName "status" tuple cityAtom <- atomForAttributeName "city" tuple if cityAtom == TextAtom "Paris" then - Right $ updateTupleWithAtoms (M.singleton "status" (IntAtom ((castInt statusAtom) + 10))) tuple + Right $ updateTupleWithAtoms (M.singleton "status" (IntAtom (castInt statusAtom + 10))) tuple else Right tuple) suppliersRel dateExampleRelTests = [("x:=s where true", Right suppliersRel), - ("x:=s where city = \"London\"", restrict (\tuple -> atomForAttributeName "city" tuple == (Right $ TextAtom "London")) suppliersRel), + ("x:=s where city = \"London\"", restrict (\tuple -> pure $ atomForAttributeName "city" tuple == (Right $ TextAtom "London")) suppliersRel), ("x:=s where false", Right $ Relation (attributes suppliersRel) emptyTupleSet), ("x:=p where color=\"Blue\" and city=\"Paris\"", mkRelationFromList (attributes productsRel) [[TextAtom "P5", TextAtom "Cam", TextAtom "Blue", IntAtom 12, TextAtom "Paris"]]), ("a:=s; update a (status:=50); x:=a{status}", mkRelation (A.attributesFromList [Attribute "status" IntAtomType]) (RelationTupleSet [mkRelationTuple (A.attributesFromList [Attribute "status" IntAtomType]) (V.fromList [IntAtom 50])])), @@ -112,12 +114,12 @@ ("x:=s where ^sum(@status)", Left $ AtomTypeMismatchError IntAtomType BoolAtomType), ("x:=s where ^not(gte(@status,20))", mkRelationFromList (attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntAtom 10, TextAtom "Paris"]]), --test "all but" attribute inversion syntax - ("x:=s{all but s#} = s{city,sname,status}", Right $ relationTrue), + ("x:=s{all but s#} = s{city,sname,status}", Right relationTrue), --test key syntax ("x:=s; key testconstraint {s#,city} x; insert x relation{tuple{city \"London\", s# \"S1\", sname \"gonk\", status 50}}", Left (InclusionDependencyCheckError "testconstraint")), - ("y:=s; key testconstraint {s#} y; insert y relation{tuple{city \"London\", s# \"S6\", sname \"gonk\", status 50}}; x:=y{s#} = s{s#} union relation{tuple{s# \"S6\"}}", Right $ relationTrue), + ("y:=s; key testconstraint {s#} y; insert y relation{tuple{city \"London\", s# \"S6\", sname \"gonk\", status 50}}; x:=y{s#} = s{s#} union relation{tuple{s# \"S6\"}}", Right relationTrue), --test binary bytestring data type - ("x:=relation{tuple{y makeByteString(\"dGVzdGRhdGE=\")}}", mkRelationFromList byteStringAttributes [[ByteStringAtom (TE.encodeUtf8 "testdata")]]), + ("x:=relation{tuple{y bytestring(\"dGVzdGRhdGE=\")}}", mkRelationFromList byteStringAttributes [[ByteStringAtom (TE.encodeUtf8 "testdata")]]), --test Maybe Text ("x:=relation{tuple{a Just \"spam\"}}", mkRelationFromList simpleMaybeTextAttributes [[ConstructedAtom "Just" maybeTextAtomType [TextAtom "spam"]]]), --test Maybe Int @@ -160,7 +162,7 @@ DisplayParseErrorResult _ _ -> assertFailure "displayparseerror?" DisplayErrorResult err -> assertFailure (show err) QuietSuccessResult -> do - commit sessionId dbconn ForbidEmptyCommitOption >>= maybeFail + commit sessionId dbconn >>= eitherFail discon <- disconnectedTransaction_ sessionId dbconn let context = Discon.concreteDatabaseContext discon assertEqual "ensure x was added" (M.lookup "x" (relationVariables context)) (Just suppliersRel) @@ -169,44 +171,35 @@ transactionRollbackTest = TestCase $ do (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback graph <- transactionGraph_ dbconn - maybeErr <- executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())) - case maybeErr of - Just err -> assertFailure (show err) - Nothing -> do - rollback sessionId dbconn >>= maybeFail - discon <- disconnectedTransaction_ sessionId dbconn - graph' <- transactionGraph_ dbconn - assertEqual "validate context" Nothing (M.lookup "x" (relationVariables (Discon.concreteDatabaseContext discon))) - let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg) - assertEqual "validate graph" (graphEq graph) (graphEq graph') + executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())) >>= eitherFail + rollback sessionId dbconn >>= eitherFail + discon <- disconnectedTransaction_ sessionId dbconn + graph' <- transactionGraph_ dbconn + assertEqual "validate context" Nothing (M.lookup "x" (relationVariables (Discon.concreteDatabaseContext discon))) + let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg) + assertEqual "validate graph" (graphEq graph) (graphEq graph') --commit a new transaction with "x" relation, jump to first transaction, verify that "x" is not present transactionJumpTest :: Test transactionJumpTest = TestCase $ do (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback (DisconnectedTransaction firstUUID _ _) <- disconnectedTransaction_ sessionId dbconn - maybeErr <- executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())) - case maybeErr of - Just err -> assertFailure (show err) - Nothing -> do - commit sessionId dbconn ForbidEmptyCommitOption >>= maybeFail - --perform the jump - maybeErr2 <- executeGraphExpr sessionId dbconn (JumpToTransaction firstUUID) - case maybeErr2 of - Just err -> assertFailure (show err) - Nothing -> do - --check that the disconnected transaction does not include "x" - discon <- disconnectedTransaction_ sessionId dbconn - assertEqual "ensure x is not present" Nothing (M.lookup "x" (relationVariables (Discon.concreteDatabaseContext discon))) + executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())) >>= eitherFail + commit sessionId dbconn >>= eitherFail + --perform the jump + executeGraphExpr sessionId dbconn (JumpToTransaction firstUUID) >>= eitherFail + --check that the disconnected transaction does not include "x" + discon <- disconnectedTransaction_ sessionId dbconn + assertEqual "ensure x is not present" Nothing (M.lookup "x" (relationVariables (Discon.concreteDatabaseContext discon))) --branch from the first transaction and verify that there are two heads transactionBranchTest :: Test transactionBranchTest = TestCase $ do (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback - mapM_ (\x -> x >>= maybeFail) [executeGraphExpr sessionId dbconn (Branch "test"), - executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())), - commit sessionId dbconn ForbidEmptyCommitOption, - executeGraphExpr sessionId dbconn (JumpToHead "master"), - executeDatabaseContextExpr sessionId dbconn (Assign "y" (RelationVariable "s" ())) + mapM_ (>>= eitherFail) [executeGraphExpr sessionId dbconn (Branch "test"), + executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())), + commit sessionId dbconn, + executeGraphExpr sessionId dbconn (JumpToHead "master"), + executeDatabaseContextExpr sessionId dbconn (Assign "y" (RelationVariable "s" ())) ] graph <- transactionGraph_ dbconn assertBool "master branch exists" $ isJust (transactionForHead "master" graph) @@ -252,15 +245,14 @@ testNotification :: Test testNotification = TestCase $ do notifmvar <- newEmptyMVar - let notifCallback mvar = \_ _ -> putMVar mvar () + let notifCallback mvar _ _ = putMVar mvar () relvarx = RelationVariable "x" () (sess, conn) <- dateExamplesConnection (notifCallback notifmvar) - let check' x = x >>= maybe (pure ()) (\err -> assertFailure (show err)) - check' $ executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue)) - check' $ executeDatabaseContextExpr sess conn (AddNotification "test notification" relvarx relvarx) - check' $ commit sess conn ForbidEmptyCommitOption - check' $ executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationFalse)) - check' $ commit sess conn ForbidEmptyCommitOption + executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue)) >>= eitherFail + executeDatabaseContextExpr sess conn (AddNotification "test notification" relvarx relvarx) >>= eitherFail + commit sess conn >>= eitherFail + executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationFalse)) >>= eitherFail + commit sess conn >>= eitherFail takeMVar notifmvar testTypeConstructors :: Test @@ -327,6 +319,13 @@ let testBranchBacktrack = TransactionIdHeadNameLookup "testbranch" [TransactionIdHeadParentBacktrack 1] backtrackRel <- executeTransGraphRelationalExpr sessionId dbconn (Equals (RelationVariable "s" testBranchBacktrack) (RelationVariable "s" masterMarker)) assertEqual "backtrack to master" (Right relationTrue) backtrackRel + + --test walkback to time (stay in current location) + now <- getCurrentTime + headId <- headTransactionId sessionId dbconn + _ <- executeGraphExpr sessionId dbconn (WalkBackToTime now) + headId' <- headTransactionId sessionId dbconn + assertEqual "transaction walk back stays in place" headId headId' --test branch deletion mapM_ (executeTutorialD sessionId dbconn) [ @@ -338,8 +337,7 @@ case eEvald of DisplayErrorResult err -> assertEqual "testbranch deletion" (show (NoSuchHeadNameError "testbranch")) (unpack err) _ -> assertFailure "failed to delete branch" - - + testMultiAttributeRename :: Test testMultiAttributeRename = TestCase $ assertTutdEqual dateExamples renamedRel "x:=s rename {city as town, status as price} where false" where @@ -360,13 +358,10 @@ eLightProduct <- executeRelationalExpr sessionId dbconn (RelationVariable "light_product" ()) lightProduct <- assertEither eLightProduct let restriction = NotPredicate (AtomExprPredicate (FunctionAtomExpr "gte" [NakedAtomExpr (IntAtom 17), AttributeAtomExpr "weight"] ())) - mErr <- setCurrentSchemaName sessionId dbconn Sess.defaultSchemaName - case mErr of - Just err -> assertFailure (show err) - Nothing -> do - eRestrictedProduct <- executeRelationalExpr sessionId dbconn (Restrict restriction (RelationVariable "p" ())) - restrictedProduct <- assertEither eRestrictedProduct - assertEqual "light product" restrictedProduct lightProduct + setCurrentSchemaName sessionId dbconn Sess.defaultSchemaName >>= eitherFail + eRestrictedProduct <- executeRelationalExpr sessionId dbconn (Restrict restriction (RelationVariable "p" ())) + restrictedProduct <- assertEither eRestrictedProduct + assertEqual "light product" restrictedProduct lightProduct assertEither :: (Show a) => Either a b -> IO b assertEither x = case x of @@ -388,6 +383,23 @@ [TextAtom "Athens", IntAtom 0]] assertEqual "validate parts count" expectedRel eRv + executeTutorialD sessionId dbconn "rv1:=relation{tuple{test 1}}" + executeTutorialD sessionId dbconn "rv2:=relation{tuple{val 1},tuple{val 2}}" + --check subexpression evaluation in restriction predicate + -- "rv1 where ((rv2 where val=@test) {})" + let correctSubexpr = Restrict (AttributeEqualityPredicate "val" (AttributeAtomExpr "test")) (RelationVariable "rv2" ()) + mainExpr subexpr = Restrict + (RelationalExprPredicate + (Project AN.empty subexpr)) (RelationVariable "rv1" ()) + eRv2 <- executeRelationalExpr sessionId dbconn (mainExpr correctSubexpr) + let expectedRel2 = mkRelationFromList (attributesFromList [Attribute "test" IntAtomType]) [[IntAtom 1]] + assertEqual "validate sub-expression attribute" expectedRel2 eRv2 + + --check error in subexpression + let wrongSubexpr = Restrict (AttributeEqualityPredicate "nosuchattr" (AttributeAtomExpr "test")) (RelationVariable "rv2" ()) + eRv3 <- executeRelationalExpr sessionId dbconn (mainExpr wrongSubexpr) + assertEqual "validate missing attribute in subexpression" (Left (NoSuchAttributeNamesError (S.singleton "nosuchattr"))) eRv3 + -- | Add a functional dependency on sname -> status and insert one tuple which is valid and another tuple which is invalid. testFunctionalDependencies :: Test testFunctionalDependencies = TestCase $ do @@ -402,31 +414,39 @@ testEmptyCommits :: Test testEmptyCommits = TestCase $ do (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback - err1 <- executeGraphExpr sessionId dbconn (Commit ForbidEmptyCommitOption) - assertEqual "no updates empty commit" (Just EmptyCommitError) err1 + dirty <- disconnectedTransactionIsDirty sessionId dbconn + assertEqual "no change not dirty" (Right False) dirty + Right () <- commit sessionId dbconn + --insert no tuples - Nothing <- executeDatabaseContextExpr sessionId dbconn (Insert "s" (RelationVariable "s" ())) - err2 <- executeGraphExpr sessionId dbconn (Commit ForbidEmptyCommitOption) - assertEqual "empty insert empty commit" (Just EmptyCommitError) err2 - --update no tuples - Nothing <- executeDatabaseContextExpr sessionId dbconn (Update "s" (M.singleton "sname" (NakedAtomExpr (TextAtom "Bob"))) (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike")))) - err3 <- executeGraphExpr sessionId dbconn (Commit ForbidEmptyCommitOption) - assertEqual "empty update empty commit" (Just EmptyCommitError) err3 - --delete no tuples - Nothing <- executeDatabaseContextExpr sessionId dbconn (Delete "s" (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike")))) - err4 <- executeGraphExpr sessionId dbconn (Commit ForbidEmptyCommitOption) - assertEqual "empty delete empty commit" (Just EmptyCommitError) err4 + Right () <- executeDatabaseContextExpr sessionId dbconn (Insert "s" (RelationVariable "s" ())) + dirty' <- disconnectedTransactionIsDirty sessionId dbconn + assertEqual "empty insert empty commit" (Right False) dirty' + Right () <- commit sessionId dbconn - --test allow empty commit option - headId5 <- headTransactionId sessionId dbconn - err5 <- executeGraphExpr sessionId dbconn (Commit AllowEmptyCommitOption) - assertEqual "allow empty commit" Nothing err5 - headId5' <- headTransactionId sessionId dbconn - assertBool "different heads" (headId5 /= headId5') + --update no tuples + Right () <- executeDatabaseContextExpr sessionId dbconn (Update "s" (M.singleton "sname" (NakedAtomExpr (TextAtom "Bob"))) (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike")))) + dirty'' <- disconnectedTransactionIsDirty sessionId dbconn + assertEqual "empty update empty commit" (Right False) dirty'' + Right () <- commit sessionId dbconn - --test ignore empty commit option - headId6 <- headTransactionId sessionId dbconn - err6 <- executeGraphExpr sessionId dbconn (Commit IgnoreEmptyCommitOption) - assertEqual "ignore empty commit" Nothing err6 - headId6' <- headTransactionId sessionId dbconn - assertEqual "same heads" headId6 headId6' + --delete no tuples + Right () <- executeDatabaseContextExpr sessionId dbconn (Delete "s" (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike")))) + dirty''' <- disconnectedTransactionIsDirty sessionId dbconn + assertEqual "empty delete empty commit" (Right False) dirty''' + +testIntervalAtom :: Test +testIntervalAtom = TestCase $ do + --test interval creation + (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback + executeTutorialD sessionId dbconn "x:=relation{tuple{n 1, a interval(3,4,f,f), b interval(4,5,f,f)}, tuple{n 2,a interval(3,4,t,t), b interval(4,5,t,t)}}" + --test failed interval creation + let err1 = "AtomFunctionUserError InvalidIntervalOrdering" + err2 = "AtomFunctionUserError (AtomTypeDoesNotSupportInterval \"Text\")" + expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "z:=relation{tuple{a interval(4,3,f,f)}}" + expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "z:=relation{tuple{a interval(\"s\",\"t\",f,f)}}" + + --test interval_overlaps + executeTutorialD sessionId dbconn "y:=x:{c:=interval_overlaps(@a,@b)}" + eRv <- executeRelationalExpr sessionId dbconn (Project (AttributeNames (S.fromList ["n","c"])) (RelationVariable "y" ())) + assertEqual "interval overlap check" (mkRelationFromList (attributesFromList [Attribute "c" BoolAtomType,Attribute "n" IntAtomType]) [[BoolAtom True, IntAtom 1], [BoolAtom False, IntAtom 2]]) eRv diff --git a/test/TutorialD/Interpreter/AtomFunctionScript.hs b/test/TutorialD/Interpreter/AtomFunctionScript.hs --- a/test/TutorialD/Interpreter/AtomFunctionScript.hs +++ b/test/TutorialD/Interpreter/AtomFunctionScript.hs @@ -8,6 +8,7 @@ import qualified Data.Vector as V import qualified Data.Map as M +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} main :: IO () main = do tcounts <- runTestTT (TestList [testBasicAtomFunction, diff --git a/test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs b/test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs --- a/test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs +++ b/test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs @@ -8,7 +8,7 @@ main :: IO () main = do tcounts <- runTestTT (TestList [testBasicDBCFunction, - testErrorDBCFunction, + testErrorDBCFunction, testExceptionDBCFunction, testDBCFunctionWithAtomArguments ]) @@ -20,7 +20,7 @@ testBasicDBCFunction :: Test testBasicDBCFunction = TestCase $ do (sess, conn) <- dateExamplesConnection emptyNotificationCallback - let addfunc = "adddatabasecontextfunction \"addTrue2\" DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext \"\"\"(\\[] ctx -> pure $ execState (evalDatabaseContextExpr (Assign \"true2\" (ExistingRelation relationTrue))) ctx) :: [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext\"\"\"" + let addfunc = "adddatabasecontextfunction \"addTrue2\" DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext \"\"\"(\\[] ctx -> executeDatabaseContextExpr (Assign \"true2\" (ExistingRelation relationTrue)) ctx) :: [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext\"\"\"" executeTutorialD sess conn addfunc executeTutorialD sess conn "execute addTrue2()" let true2Expr = RelationVariable "true2" () @@ -50,7 +50,7 @@ testDBCFunctionWithAtomArguments = TestCase $ do --test function with creation of a relvar with some arguments (sess, conn) <- dateExamplesConnection emptyNotificationCallback - let addfunc = "adddatabasecontextfunction \"multiArgFunc\" Int -> Text -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext \"\"\"(\\(age:name:_) ctx -> pure $ execState (evalDatabaseContextExpr (Assign \"person\" (MakeRelationFromExprs Nothing [TupleExpr (fromList [(\"name\", NakedAtomExpr name), (\"age\", NakedAtomExpr age)])]))) ctx) :: [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext\"\"\"" + let addfunc = "adddatabasecontextfunction \"multiArgFunc\" Int -> Text -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext \"\"\"(\\(age:name:_) ctx -> executeDatabaseContextExpr (Assign \"person\" (MakeRelationFromExprs Nothing [TupleExpr (fromList [(\"name\", NakedAtomExpr name), (\"age\", NakedAtomExpr age)])])) ctx) :: [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext\"\"\"" executeTutorialD sess conn addfunc executeTutorialD sess conn "execute multiArgFunc(30,\"Steve\")" result <- executeRelationalExpr sess conn (RelationVariable "person" ()) diff --git a/test/TutorialD/Interpreter/Import/TutorialD.hs b/test/TutorialD/Interpreter/Import/TutorialD.hs --- a/test/TutorialD/Interpreter/Import/TutorialD.hs +++ b/test/TutorialD/Interpreter/Import/TutorialD.hs @@ -12,7 +12,7 @@ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess testTutdImport :: Test -testTutdImport = TestCase $ do +testTutdImport = TestCase $ withSystemTempFile "m.tutd" $ \tempPath handle -> do hPutStrLn handle "x:=relation{tuple{a 5,b \"spam\"}}" hClose handle diff --git a/test/TutorialD/Interpreter/TestBase.hs b/test/TutorialD/Interpreter/TestBase.hs --- a/test/TutorialD/Interpreter/TestBase.hs +++ b/test/TutorialD/Interpreter/TestBase.hs @@ -1,5 +1,6 @@ module TutorialD.Interpreter.TestBase where import ProjectM36.Client +import ProjectM36.Error import TutorialD.Interpreter import TutorialD.Interpreter.Base import qualified ProjectM36.Base as Base @@ -15,14 +16,14 @@ case dbconn of Left err -> error (show err) Right conn -> do - eSessionId <- createSessionAtHead "master" conn + eSessionId <- createSessionAtHead conn "master" case eSessionId of Left err -> error (show err) Right sessionId -> do mapM_ (\(rvName,rvRel) -> executeDatabaseContextExpr sessionId conn (Assign rvName (Base.ExistingRelation rvRel))) (M.toList (Base.relationVariables dateExamples)) mapM_ (\(idName,incDep) -> executeDatabaseContextExpr sessionId conn (AddInclusionDependency idName incDep)) (M.toList incDeps) --skipping atom functions for now- there are no atom function manipulation operators yet - commit sessionId conn ForbidEmptyCommitOption >>= maybeFail + commit sessionId conn >>= eitherFail pure (sessionId, conn) executeTutorialD :: SessionId -> Connection -> Text -> IO () @@ -53,6 +54,6 @@ DisplayErrorResult err -> assertBool ("match error on: " ++ unpack err) (matchFunc err) QuietSuccessResult -> pure () -maybeFail :: (Show a) => Maybe a -> IO () -maybeFail (Just err) = assertFailure (show err) -maybeFail Nothing = return () +eitherFail :: Either RelationalError a -> IO () +eitherFail (Left err) = assertFailure (show err) +eitherFail (Right _) = pure ()