@@ -0,0 +1,95 @@
1+{-# LANGUAGE CPP #-}
2+--benchmark test for file handle leaks
3+import ProjectM36.Client
4+import Options.Applicative
5+import TutorialD.Interpreter
6+import TutorialD.Interpreter.Base
7+import qualified Data.Text as T
8+import Text.Megaparsec hiding (option)
9+import Data.Monoid
10+import qualified Data.Map as M
11+import System.Directory
12+
13+type OpenCloseCount = Int
14+
15+type TransactionCount = Int
16+
17+type DbDir = String
18+
19+data HandlesArgs = HandlesArgs OpenCloseCount TransactionCount DbDir
20+
21+parseArgs :: Parser HandlesArgs
22+parseArgs = HandlesArgs <$> parseOpenAndCloseCount <*> parseTransactionCount <*> parseDbDir
23+
24+parseOpenAndCloseCount :: Parser OpenCloseCount
25+parseOpenAndCloseCount = option auto (short 'o' <> long "open-close-count")
26+
27+parseTransactionCount :: Parser TransactionCount
28+parseTransactionCount = option auto (short 't' <> long "transaction-count")
29+
30+parseDbDir :: Parser DbDir
31+parseDbDir = strOption (short 'd' <> long "dbdir")
32+
33+main :: IO ()
34+main = do
35+ (HandlesArgs ocCount tCount dbdir) <- execParser $ info (helper <*> parseArgs) fullDesc
36+ sequence_ $ replicate ocCount (runOpenClose tCount dbdir)
37+
38+runOpenClose :: TransactionCount -> DbDir -> IO ()
39+runOpenClose tCount dbdir = do
40+ let connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback []
41+ eConn <- connectProjectM36 connInfo
42+ case eConn of
43+ Left err -> error (show err)
44+ Right conn -> do
45+ eSess <- createSessionAtHead conn "master"
46+ case eSess of
47+ Left err -> error (show err)
48+ Right session -> do
49+ --database setup
50+ eErr <- executeDatabaseContextExpr session conn (Assign "x" (MakeRelationFromExprs Nothing [TupleExpr (M.singleton "v" (NakedAtomExpr (BoolAtom True)))]))
51+ case eErr of
52+ Left err -> error (show err)
53+ Right _ -> do
54+ sequence_ $ replicate tCount (runTransaction session conn)
55+ close conn
56+ printFdCount
57+
58+runTransaction :: SessionId -> Connection -> IO ()
59+runTransaction sess conn = do
60+ --run tutd on every iteration
61+ let tutd = "update x (v:=not(@v))"
62+ case parseTutorialD tutd of
63+ Left err -> error (show err)
64+ Right parsed -> do
65+ res <- evalTutorialD sess conn UnsafeEvaluation parsed
66+ case res of
67+ DisplayErrorResult err -> error (T.unpack err)
68+ DisplayParseErrorResult _ err -> error (parseErrorPretty err)
69+ _ -> do
70+ eErr <- commit sess conn
71+ case eErr of
72+ Left err -> error (show err)
73+ Right _ -> printFdCount
74+
75+--prints out number of consumed file descriptors
76+printFdCount :: IO ()
77+#if defined(linux_HOST_OS)
78+printFdCount = do
79+ fdc <- fdCount
80+ putStrLn ("Fd count: " ++ show fdc)
81+ --getLine >> pure ()
82+#else
83+printFdCount = putStrLn "Fd count not supported on this OS."
84+#endif
85+
86+
87+fdCount :: IO Int
88+#if defined(linux_HOST_OS)
89+fdCount = do
90+ fds <- getDirectoryContents "/proc/self/fd"
91+ pure ((length fds) - 2)
92+#else
93+--not supported on non-linux
94+fdCount = pure 0
95+#endif