cf93e07 · project-m36 · git.iko.soy

git.iko.soy/project-m36

more tests and binaries building with sessions

commitcf93e077f3ff8547c62c48a59d5446ff07167201 authorAgentM <agentm@themactionfaction.com> dateTue 1 Dec 2015, 17:56 (11 years ago) parentdda2c77

3 files changed+81−42

compare with master

unifiedsplit

examples/PersistClient.hs+37−3 project-m36.cabal+1−1 test/TutorialD/Interpreter.hs+43−38

examples/PersistClient.hs+37−3

@@ -1,7 +1,15 @@

1−{-# LANGUAGE TemplateHaskell #-}

1+{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies, GADTs, EmptyDataDecls, TypeSynonymInstances, FlexibleInstances, FlexibleContexts, RankNTypes, MultiParamTypeClasses, GeneralizedNewtypeDeriving, OverloadedStrings #-}

2+{-# OPTIONS_GHC -fno-warn-orphans #-}

23{- A simple example of using the persistent-ProjectM36 driver. -}

3−import Database.Persist.ProjectM36

4+import Database.Persist.ProjectM36 hiding (executeDatabaseContextExpr)

45import ProjectM36.Client

6+import ProjectM36.Atom

7+import System.Exit

8+import System.IO

9+import Database.Persist

10+import Database.Persist.TH

11+import Language.Haskell.TH.Syntax

12+import Control.Monad.Reader

513

614--1. declare the models with Template Haskell

715let projectM36PersistSettings = mkPersistSettings (ConT ''ProjectM36Backend)

@@ -14,7 +22,33 @@ Person

1422 deriving Show

1523|]

1624

25+errDie :: String -> IO ()

26+errDie out = hPutStrLn stderr out >> exitFailure

27+

28+defPersonRel :: SessionId -> Connection -> IO ()

29+defPersonRel sessionId conn = do

30+ maybeErr <- executeDatabaseContextExpr sessionId conn (Define "person" (attributesFromList [Attribute "name" stringAtomType, Attribute "age" intAtomType, Attribute "id" stringAtomType]))

31+ case maybeErr of

32+ Nothing -> return ()

33+ Just err -> errDie (show err)

34+

1735main :: IO ()

1836main = do

1937 --1. create the database connection

20− pure ()

38+ let connInfo = InProcessConnectionInfo NoPersistence

39+ withProjectM36Conn connInfo $ runProjectM36Conn $ do

40+ --2. use the underlying client connection and session to define a relation variable

41+ (sessionId, conn) <- ask

42+ liftIO $ defPersonRel sessionId conn

43+ --3. insert some data

44+ _ <- insert $ Person "Michael" 33

45+ _ <- insert $ Person "Steve" 20

46+ --4. query on a unique key

47+ michael <- getBy $ UniqueName "Michael"

48+ liftIO $ putStrLn (show michael)

49+ --5. other queries

50+ youngerThan30Users <- selectList [PersonAge <. 30] []

51+ liftIO $ putStrLn (show youngerThan30Users)

52+ -- Updates and deletes operate by normal persistent APIs.

53+ -- Sorting results is not yet supported.

54+

project-m36.cabal+1−1

@@ -286,7 +286,7 @@ Executable Example-SimpleClient

286286

287287Executable Example-PersistClient

288288 Default-Language: Haskell2010

289− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, distributed-process, distributed-process-extras, distributed-process-client-server, uuid, stm, deepseq, deepseq-generics, binary, unix, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, parsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, persistent, aeson, path-pieces, either, conduit, http-api-data

289+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, distributed-process, distributed-process-extras, distributed-process-client-server, uuid, stm, deepseq, deepseq-generics, binary, unix, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, parsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, persistent, aeson, path-pieces, either, conduit, http-api-data, template-haskell, persistent-template

290290 Main-Is: examples/PersistClient.hs

291291 GHC-Options: -Wall

292292 C-sources: ProjectM36/DirectoryFsync.c

test/TutorialD/Interpreter.hs+43−38

@@ -13,11 +13,11 @@ import qualified ProjectM36.Base as Base

1313import ProjectM36.TransactionGraph

1414import ProjectM36.Client

1515import ProjectM36.Atom

16+import ProjectM36.Session

1617import qualified ProjectM36.Attribute as A

1718import qualified Data.Map as M

1819import System.Exit

1920import Data.Maybe (isJust)

20−import System.IO

2121import qualified Data.Vector as V

2222import Data.Text.Encoding as TE

2323import Data.Typeable (Proxy(..))

@@ -26,6 +26,7 @@ import Data.Time.Clock (UTCTime(..))

2626import Data.Time.Calendar (fromGregorian)

2727import Data.Interval (interval, Interval, Extended(Finite))

2828import Control.Concurrent.STM

29+import qualified STMContainers.Map as STMMap

2930

3031main :: IO ()

3132main = do

@@ -125,38 +126,38 @@ assertTutdEqual databaseContext expected tutd = assertEqual tutd expected interp

125126

126127transactionGraphBasicTest :: Test

127128transactionGraphBasicTest = TestCase $ do

128− dbconn <- dateExamplesConnection

129+ (_, dbconn) <- dateExamplesConnection

129130 graph <- transactionGraph dbconn

130131 assertEqual "validate bootstrapped graph" (validateGraph graph) Nothing

131132

132133--add a new transaction to the graph, validate it is in the graph

133134transactionGraphAddCommitTest :: Test

134135transactionGraphAddCommitTest = TestCase $ do

135− dbconn <- dateExamplesConnection

136+ (sessionId, dbconn) <- dateExamplesConnection

136137 case parseTutorialD "x:=S" of

137138 Left err -> assertFailure (show err)

138139 Right parsed -> do

139− result <- evalTutorialD dbconn parsed

140+ result <- evalTutorialD sessionId dbconn parsed

140141 case result of

141142 QuitResult -> assertFailure "quit?"

142143 DisplayResult _ -> assertFailure "display?"

143144 DisplayIOResult _ -> assertFailure "displayIO?"

144145 DisplayErrorResult err -> assertFailure (show err)

145146 QuietSuccessResult -> do

146− commit dbconn >>= maybeFail

147− (DisconnectedTransaction _ context) <- disconnectedTransaction dbconn

147+ commit sessionId dbconn >>= maybeFail

148+ (DisconnectedTransaction _ context) <- disconnectedTransaction sessionId dbconn

148149 assertEqual "ensure x was added" (M.lookup "x" (relationVariables context)) (Just suppliersRel)

149150

150151transactionRollbackTest :: Test

151152transactionRollbackTest = TestCase $ do

152− dbconn <- dateExamplesConnection

153+ (sessionId, dbconn) <- dateExamplesConnection

153154 graph <- transactionGraph dbconn

154− maybeErr <- executeDatabaseContextExpr dbconn (Assign "x" (RelationVariable "S"))

155+ maybeErr <- executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "S"))

155156 case maybeErr of

156157 Just err -> assertFailure (show err)

157158 Nothing -> do

158− rollback dbconn >>= maybeFail

159− (DisconnectedTransaction _ context') <- disconnectedTransaction dbconn

159+ rollback sessionId dbconn >>= maybeFail

160+ (DisconnectedTransaction _ context') <- disconnectedTransaction sessionId dbconn

160161 graph' <- transactionGraph dbconn

161162 assertEqual "validate context" Nothing (M.lookup "x" (relationVariables context'))

162163 assertEqual "validate graph" graph graph'

@@ -164,20 +165,20 @@ transactionRollbackTest = TestCase $ do

164165--commit a new transaction with "x" relation, jump to first transaction, verify that "x" is not present

165166transactionJumpTest :: Test

166167transactionJumpTest = TestCase $ do

167− dbconn <- dateExamplesConnection

168− (DisconnectedTransaction firstUUID _) <- disconnectedTransaction dbconn

169− maybeErr <- executeDatabaseContextExpr dbconn (Assign "x" (RelationVariable "S"))

168+ (sessionId, dbconn) <- dateExamplesConnection

169+ (DisconnectedTransaction firstUUID _) <- disconnectedTransaction sessionId dbconn

170+ maybeErr <- executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "S"))

170171 case maybeErr of

171172 Just err -> assertFailure (show err)

172173 Nothing -> do

173− commit dbconn >>= maybeFail

174+ commit sessionId dbconn >>= maybeFail

174175 --perform the jump

175− maybeErr2 <- executeGraphExpr dbconn (JumpToTransaction firstUUID)

176+ maybeErr2 <- executeGraphExpr sessionId dbconn (JumpToTransaction firstUUID)

176177 case maybeErr2 of

177178 Just err -> assertFailure (show err)

178179 Nothing -> do

179180 --check that the disconnected transaction does not include "x"

180− (DisconnectedTransaction _ context') <- disconnectedTransaction dbconn

181+ (DisconnectedTransaction _ context') <- disconnectedTransaction sessionId dbconn

181182 assertEqual "ensure x is not present" Nothing (M.lookup "x" (relationVariables context'))

182183

183184maybeFail :: (Show a) => Maybe a -> IO ()

@@ -187,12 +188,12 @@ maybeFail Nothing = return ()

187188--branch from the first transaction and verify that there are two heads

188189transactionBranchTest :: Test

189190transactionBranchTest = TestCase $ do

190− dbconn <- dateExamplesConnection

191− mapM_ (\x -> x >>= maybeFail) [executeGraphExpr dbconn (Branch "test"),

192− executeDatabaseContextExpr dbconn (Assign "x" (RelationVariable "S")),

193− commit dbconn,

194− executeGraphExpr dbconn (JumpToHead "master"),

195− executeDatabaseContextExpr dbconn (Assign "y" (RelationVariable "S"))

191+ (sessionId, dbconn) <- dateExamplesConnection

192+ mapM_ (\x -> x >>= maybeFail) [executeGraphExpr sessionId dbconn (Branch "test"),

193+ executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "S")),

194+ commit sessionId dbconn,

195+ executeGraphExpr sessionId dbconn (JumpToHead "master"),

196+ executeDatabaseContextExpr sessionId dbconn (Assign "y" (RelationVariable "S"))

196197 ]

197198 graph <- transactionGraph dbconn

198199 assertBool "master branch exists" $ isJust (transactionForHead "master" graph)

@@ -221,16 +222,18 @@ simpleJoinTest = TestCase $ assertTutdEqual dateExamples joinedRel "x:=S join SP

221222 [stringAtom "London", intAtom 200, stringAtom "P2", stringAtom "S4", stringAtom "Clark", intAtom 20]

222223 ]

223224transactionGraph :: Connection -> IO TransactionGraph

224−transactionGraph (InProcessConnection _ tvar) = atomically $ do

225− (_, graph) <- readTVar tvar

226− pure graph

225+transactionGraph (InProcessConnection _ _ tvar) = atomically $ readTVar tvar

226+

227227transactionGraph _ = error "remote connection used"

228228

229−disconnectedTransaction :: Connection -> IO DisconnectedTransaction

230−disconnectedTransaction (InProcessConnection _ tvar) = atomically $ do

231− (discon, _) <- readTVar tvar

232− pure discon

233−disconnectedTransaction _ = error "remote connection used"

229+disconnectedTransaction :: SessionId -> Connection -> IO DisconnectedTransaction

230+disconnectedTransaction sessionId (InProcessConnection _ sessions _) = do

231+ mSession <- atomically $ do

232+ STMMap.lookup sessionId sessions

233+ case mSession of

234+ Nothing -> error "No such session"

235+ Just (Session discon) -> pure discon

236+disconnectedTransaction _ _ = error "remote connection used"

234237

235238{-

236239inclusionDependencies :: Connection -> M.Map IncDepName InclusionDependency

@@ -238,19 +241,21 @@ inclusionDependencies (InProcessConnection (DisconnectedTransaction _ context))

238241inclusionDependencies _ = error "remote connection used"

239242-}

240243

241−dateExamplesConnection :: IO (Connection)

244+dateExamplesConnection :: IO (SessionId, Connection)

242245dateExamplesConnection = do

243246 dbconn <- connectProjectM36 (InProcessConnectionInfo NoPersistence)

244247 let incDeps = Base.inclusionDependencies dateExamples

245248 case dbconn of

246− Left err -> do

247− hPutStrLn stderr (show err)

248− exitFailure

249+ Left err -> error (show err)

249250 Right conn -> do

250− mapM_ (\(rvName,rvRel) -> executeDatabaseContextExpr conn (Assign rvName (ExistingRelation rvRel))) (M.toList (relationVariables dateExamples))

251− mapM_ (\(idName,incDep) -> executeDatabaseContextExpr conn (AddInclusionDependency idName incDep)) (M.toList incDeps)

251+ eSessionId <- createSessionAtHead "master" conn

252+ case eSessionId of

253+ Left err -> error (show err)

254+ Right sessionId -> do

255+ mapM_ (\(rvName,rvRel) -> executeDatabaseContextExpr sessionId conn (Assign rvName (ExistingRelation rvRel))) (M.toList (relationVariables dateExamples))

256+ mapM_ (\(idName,incDep) -> executeDatabaseContextExpr sessionId conn (AddInclusionDependency idName incDep)) (M.toList incDeps)

252257 --skipping atom functions for now- there are no atom function manipulation operators yet

253− commit conn >>= maybeFail

254− return conn

258+ commit sessionId conn >>= maybeFail

259+ pure (sessionId, conn)

255260

256261