git.iko.soy/project-m36
on master help sign in
initial version of Simple client monad
89c2576AgentM
project-m36.cabal+11
compare with master
unifiedsplit
@@ -114,6 +114,7 @@ Library
114 ProjectM36.IsomorphicSchema,
114 ProjectM36.IsomorphicSchema,
115 ProjectM36.InclusionDependency,
115 ProjectM36.InclusionDependency,
116 ProjectM36.Client,
116 ProjectM36.Client,
117+ ProjectM36.Client.Simple,
117 ProjectM36.Persist,
118 ProjectM36.Persist,
118 ProjectM36.AtomType,
119 ProjectM36.AtomType,
119 ProjectM36.AtomFunctions.Basic,
120 ProjectM36.AtomFunctions.Basic,
@@ -490,3 +491,13 @@ Test-Suite test-transactiongraph-automerge
490 GHC-Options: -Wall
491 GHC-Options: -Wall
491 Hs-Source-Dirs: ./src/bin, ., test/
492 Hs-Source-Dirs: ./src/bin, ., test/
492 CPP-Options: -DPROJECTM36_VERSION="v0.1"
493 CPP-Options: -DPROJECTM36_VERSION="v0.1"
494+
495+Test-Suite test-client-simple
496+ Default-Language: Haskell2010
497+ Main-Is: test/Client/Simple.hs
498+ type: exitcode-stdio-1.0
499+ 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, random, MonadRandom, semigroups
500+ Default-Extensions: OverloadedStrings
501+ GHC-Options: -Wall
502+ Hs-Source-Dirs: ./src/bin, ., test/
503+ CPP-Options: -DPROJECTM36_VERSION="v0.1"
src/lib/ProjectM36/Client/Simple.hsnew file+79
@@ -0,0 +1,79 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+module ProjectM36.Client.Simple (
3+ withDBConnection,
4+ withTransaction,
5+ executeDatabaseContextExpr,
6+ executeRelationalExpr,
7+ Atom(..),
8+ AtomType(..),
9+ DBError(..),
10+ Attribute(..),
11+ C.ConnectionInfo(..),
12+ C.PersistenceStrategy(..),
13+ C.NotificationCallback(..),
14+ C.emptyNotificationCallback,
15+ C.DatabaseContextExpr(..),
16+ C.RelationalExprBase(..)
17+ ) where
18+-- | A simplified, monad-based client for Project:M36 database access.
19+import ProjectM36.Error
20+import ProjectM36.Base
21+import qualified ProjectM36.Client as C
22+import Control.Monad.Reader
23+import Control.Exception.Base
24+
25+-- | A union of connection and other errors that can be returned from 'withDBConnection'.
26+data DBError = ConnError C.ConnectionError |
27+ RelError RelationalError
28+ deriving (Eq, Show)
29+
30+newtype DB a = DB {runDB :: ReaderT (C.SessionId, C.Connection) IO a}
31+ deriving (Functor, Applicative, Monad, MonadIO)
32+
33+-- | Opens a connection in the 'DB' monad and closes it after running the monad.
34+withDBConnection :: C.ConnectionInfo -> DB (Either DBError a) -> IO (Either DBError a)
35+withDBConnection connInfo block = bracket (C.connectProjectM36 connInfo) (\eConn -> case eConn of
36+ Left err -> pure (Right ())
37+ Right conn -> C.close conn >> pure (Right ())) $ \eConn -> do
38+ case eConn of
39+ Left err -> pure (Left (ConnError err))
40+ Right conn -> do
41+ eSess <- C.createSessionAtHead conn "master"
42+ case eSess of
43+ Left err -> pure (Left (RelError err))
44+ Right session ->
45+ runReaderT (runDB block) (session, conn)
46+
47+wrapClientIO :: (C.SessionId -> C.Connection -> IO (Either RelationalError a)) -> DB (Either DBError a)
48+wrapClientIO func = DB $ do
49+ (sess, conn) <- ask
50+ ret <- liftIO (func sess conn)
51+ case ret of
52+ Left err -> pure (Left (RelError err))
53+ Right val -> pure (Right val)
54+
55+-- | Atomically commits the result of the database context expression to disk on the server or restores the initial state.
56+withTransaction :: C.DatabaseContextExpr -> DB (Either DBError ())
57+withTransaction expr = do
58+ ret <- executeDatabaseContextExpr expr
59+ case ret of
60+ Left err -> pure (Left err)
61+ Right _ -> do
62+ eCurrentHead <- wrapClientIO C.headName
63+ case eCurrentHead of
64+ Left err -> pure (Left err)
65+ Right currentHead ->
66+ wrapClientIO (\sess conn -> C.autoMergeToHead sess conn C.UnionMergeStrategy currentHead)
67+
68+-- | Execute a 'DatabaseContextExpr' in the 'DB' monad. Database context expressions manipulate the state of the database.
69+executeDatabaseContextExpr :: C.DatabaseContextExpr -> DB (Either DBError ())
70+executeDatabaseContextExpr expr = DB $ do
71+ (sess, conn) <- ask
72+ eErr <- liftIO $ C.executeDatabaseContextExpr sess conn expr
73+ case eErr of
74+ Left err -> pure (Left (RelError err))
75+ Right () -> pure (Right ())
76+
77+-- | Execute a 'RelationalExpr' in the 'DB' monad. Relational expressions perform read-only queries against the current database state.
78+executeRelationalExpr :: C.RelationalExpr -> DB (Either DBError Relation)
79+executeRelationalExpr expr = wrapClientIO (\sess conn -> C.executeRelationalExpr sess conn expr)
test/Client/Simple.hsnew file+66
@@ -0,0 +1,66 @@
1+import ProjectM36.Client.Simple
2+import Test.HUnit
3+import System.Exit
4+import ProjectM36.Relation
5+import qualified ProjectM36.Client as C
6+import System.IO.Temp
7+import System.FilePath
8+import ProjectM36.TupleSet
9+import ProjectM36.Attribute
10+import ProjectM36.Error
11+import qualified Data.Vector as V
12+
13+main :: IO ()
14+main = do
15+ tcounts <- runTestTT testList
16+ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
17+
18+testList :: Test
19+testList = TestList [testSimpleCommitSuccess, testSimpleCommitFailure]
20+
21+assertEither :: (Show a) => IO (Either a b) -> IO b
22+assertEither x = do
23+ res <- x
24+ case res of
25+ Left err -> assertFailure (show err) >> undefined
26+ Right val -> pure val
27+
28+testSimpleCommitSuccess :: Test
29+testSimpleCommitSuccess = TestCase $
30+ withSystemTempDirectory "m36tempdb" $ \tempdir -> do
31+ let connInfo = InProcessConnectionInfo (MinimalPersistence (tempdir </> "db")) emptyNotificationCallback []
32+ relExpr = Union (RelationVariable "x" ()) (RelationVariable "y" ())
33+
34+ Right _ <- withDBConnection connInfo $ do
35+ Right _ <- withTransaction (MultipleExpr [
36+ Assign "x" (ExistingRelation relationTrue),
37+ Assign "y" (ExistingRelation relationFalse)
38+ ])
39+ executeRelationalExpr relExpr
40+
41+ -- re-open with standard API and validate that the relvars are available
42+ conn <- assertEither $ C.connectProjectM36 connInfo
43+
44+ sess <- assertEither $ C.createSessionAtHead conn "master"
45+ eRes <- C.executeRelationalExpr sess conn relExpr
46+ assertEqual "x and y" (Right relationTrue) eRes
47+
48+testSimpleCommitFailure :: Test
49+testSimpleCommitFailure = TestCase $ do
50+ let failAttrs = attributesFromList [Attribute "fail" IntAtomType]
51+ err <- withSystemTempDirectory "m36tempdb" $ \tempdir -> do
52+ let connInfo = InProcessConnectionInfo (MinimalPersistence (tempdir </> "db")) emptyNotificationCallback []
53+ withDBConnection connInfo $ do
54+ Right _ <- withTransaction (Assign "x" (ExistingRelation relationTrue))
55+ --cause error
56+ withTransaction (Assign "x" (MakeStaticRelation failAttrs emptyTupleSet))
57+ let expectedErr = Left (RelError (RelVarAssignmentTypeMismatchError V.empty failAttrs))
58+ assertEqual "dbc error" expectedErr err
59+
60+
61+
62+
63+
64+
65+
66+