git.iko.soy/project-m36
on d64cdeb help sign in
project-m36/test/TransactionGraph/Persist.hs
104 lines 4.7 kB history raw
1import Test.HUnit
2import ProjectM36.Base
3import ProjectM36.Persist (DiskSync(NoDiskSync))
4import ProjectM36.TransactionGraph.Persist
5import ProjectM36.TransactionGraph
6import ProjectM36.Transaction
7import ProjectM36.DateExamples
8import ProjectM36.Client
9import ProjectM36.Relation
10import System.IO.Temp
11import System.Exit
12import Data.Either
13import Data.UUID.V4 (nextRandom)
14import System.FilePath
15import TutorialD.Interpreter.DatabaseContextExpr
16import qualified Data.Map as M
17import qualified Data.Set as S
18import Data.Time.Clock
19import Data.Time.Calendar
21main :: IO ()
22main = do
23 tcounts <- runTestTT testList
24 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
26testList :: Test
27testList = TestList [testBootstrapDB,
28 testDBSimplePersistence,
29 testFunctionPersistence]
31stamp :: UTCTime
32stamp = UTCTime (fromGregorian 1980 01 01) (secondsToDiffTime 1000)
34{- bootstrap a database, ensure that it can be read -}
35testBootstrapDB :: Test
36testBootstrapDB = TestCase $ withSystemTempDirectory "m36testdb" $ \tempdir -> do
37 let dbdir = tempdir </> "dbdir"
38 freshId <- nextRandom
40 _ <- bootstrapDatabaseDir NoDiskSync dbdir (bootstrapTransactionGraph stamp freshId dateExamples)
41 loadedGraph <- transactionGraphLoad dbdir emptyTransactionGraph Nothing
42 assertBool "transactionGraphLoad" $ isRight loadedGraph
44{- create a database with several transactions, ensure that all transactions can be read -}
45testDBSimplePersistence :: Test
46testDBSimplePersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \tempdir -> do
47 let dbdir = tempdir </> "dbdir"
48 freshId <- nextRandom
50 let graph = bootstrapTransactionGraph stamp freshId dateExamples
51 _ <- bootstrapDatabaseDir NoDiskSync dbdir graph
52 case transactionForHead "master" graph of
53 Nothing -> assertFailure "Failed to retrieve head transaction for master branch."
54 Just headTrans ->
55 case interpretDatabaseContextExpr (concreteDatabaseContext headTrans) "x:=s" of
56 Left err -> assertFailure (show err)
57 Right context' -> do
58 freshId' <- nextRandom
59 let newdiscon = DisconnectedTransaction (transactionId headTrans) (Schemas context' M.empty) True
60 addTrans = addDisconnectedTransaction stamp freshId' "master" newdiscon graph
61 --add a transaction to the graph
62 case addTrans of
63 Left err -> assertFailure (show err)
64 Right (_, graph') -> do
65 --persist the new graph
66 _ <- transactionGraphPersist NoDiskSync dbdir [freshId'] graph'
67 --reload the graph from the filesystem and confirm that the transaction is present
68 graphErr <- transactionGraphLoad dbdir emptyTransactionGraph Nothing
69 let mapEq graphArg = S.map transactionId (transactionsForGraph graphArg)
70 case graphErr of
71 Left err -> assertFailure (show err)
72 Right graph'' -> assertBool "graph equality" (mapEq graph'' == mapEq graph')
75--only Haskell-scripted dbc and atom functions can be serialized
76testFunctionPersistence :: Test
77testFunctionPersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \tempdir -> do
78 let dbdir = tempdir </> "dbdir"
79 connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback []
80 conn <- assertIOEither $ connectProjectM36 connInfo
81 sess <- assertIOEither $ createSessionAtHead conn "master"
82 let intTCons = PrimitiveTypeConstructor "Int" IntAtomType
83 addfunc = AddAtomFunction "testdisk" [
84 intTCons,
85 ADTypeConstructor "Either" [ADTypeConstructor "AtomFunctionError" [],
86 intTCons]] "(\\(x:_) -> pure x) :: [Atom] -> Either AtomFunctionError Atom"
87 _ <- assertIOEither $ executeDatabaseContextIOExpr sess conn addfunc
89 _ <- assertIOEither $ commit sess conn
90 close conn
91 --re-open the connection to reload the graph
92 conn2 <- assertIOEither $ connectProjectM36 connInfo
93 sess2 <- assertIOEither $ createSessionAtHead conn2 "master"
95 res <- executeRelationalExpr sess2 conn2 (MakeRelationFromExprs Nothing [TupleExpr (M.singleton "a" (FunctionAtomExpr "testdisk" [NakedAtomExpr (IntAtom 3)] ()))])
96 let expectedRel = mkRelationFromList (attributesFromList [Attribute "a" IntAtomType]) [[IntAtom 3]]
97 assertEqual "testdisk dbc function run" expectedRel res
99assertIOEither :: (Show a) => IO (Either a b) -> IO b
100assertIOEither x = do
101 ret <- x
102 case ret of
103 Left err -> assertFailure (show err) >> undefined
104 Right val -> pure val