git.iko.soy/project-m36
on master help sign in
Merge branch '145_leaking_fds'
commit717dacaf877eaa3ebb6d81eb22e86c6316ea3e0a authorAgentM <agentm@themactionfaction.com> dateMon 18 Sep 2017, 23:11 (9 years ago) parent7a64a4daa730ee
7 files changed+183−45
compare with master
unifiedsplit
project-m36.cabal+27 src/bin/benchmark/Handles.hs+96 src/lib/ProjectM36/Client.hs+6−3 src/lib/ProjectM36/FileLock.hs+30−14 src/lib/ProjectM36/Transaction/Persist.hs+11−12 src/lib/ProjectM36/TransactionGraph/Persist.hs+9−15 stack.yaml+4−1
project-m36.cabal+27
@@ -504,3 +504,30 @@ Test-Suite test-client-simple
504504 GHC-Options: -Wall
505505 Hs-Source-Dirs: ./src/bin, ., test/
506506
507+-- test for file handle leaks
508+Executable handles
509+ Default-Language: Haskell2010
510+ Default-Extensions: OverloadedStrings
511+ 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
512+ main-is: benchmark/Handles.hs
513+ Other-Modules: TutorialD.Interpreter,
514+ TutorialD.Interpreter.Base,
515+ TutorialD.Interpreter.DatabaseContextExpr,
516+ TutorialD.Interpreter.DatabaseContextIOOperator,
517+ TutorialD.Interpreter.Export.Base,
518+ TutorialD.Interpreter.Export.CSV,
519+ TutorialD.Interpreter.Import.Base,
520+ TutorialD.Interpreter.Import.BasicExamples,
521+ TutorialD.Interpreter.Import.CSV,
522+ TutorialD.Interpreter.Import.TutorialD,
523+ TutorialD.Interpreter.InformationOperator,
524+ TutorialD.Interpreter.RODatabaseContextOperator,
525+ TutorialD.Interpreter.RelationalExpr,
526+ TutorialD.Interpreter.SchemaOperator,
527+ TutorialD.Interpreter.TransGraphRelationalOperator,
528+ TutorialD.Interpreter.TransactionGraphOperator,
529+ TutorialD.Interpreter.Types
530+ GHC-Options: -Wall -threaded -rtsopts
531+ HS-Source-Dirs: ./src/bin
532+ if flag(profiler)
533+ GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall
src/bin/benchmark/Handles.hsnew file+96
@@ -0,0 +1,96 @@
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+import Control.Monad
13+
14+type OpenCloseCount = Int
15+
16+type TransactionCount = Int
17+
18+type DbDir = String
19+
20+data HandlesArgs = HandlesArgs OpenCloseCount TransactionCount DbDir
21+
22+parseArgs :: Parser HandlesArgs
23+parseArgs = HandlesArgs <$> parseOpenAndCloseCount <*> parseTransactionCount <*> parseDbDir
24+
25+parseOpenAndCloseCount :: Parser OpenCloseCount
26+parseOpenAndCloseCount = option auto (short 'o' <> long "open-close-count")
27+
28+parseTransactionCount :: Parser TransactionCount
29+parseTransactionCount = option auto (short 't' <> long "transaction-count")
30+
31+parseDbDir :: Parser DbDir
32+parseDbDir = strOption (short 'd' <> long "dbdir")
33+
34+main :: IO ()
35+main = do
36+ (HandlesArgs ocCount tCount dbdir) <- execParser $ info (helper <*> parseArgs) fullDesc
37+ replicateM_ ocCount (runOpenClose tCount dbdir)
38+
39+runOpenClose :: TransactionCount -> DbDir -> IO ()
40+runOpenClose tCount dbdir = do
41+ let connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback []
42+ eConn <- connectProjectM36 connInfo
43+ case eConn of
44+ Left err -> error (show err)
45+ Right conn -> do
46+ eSess <- createSessionAtHead conn "master"
47+ case eSess of
48+ Left err -> error (show err)
49+ Right session -> do
50+ --database setup
51+ eErr <- executeDatabaseContextExpr session conn (Assign "x" (MakeRelationFromExprs Nothing [TupleExpr (M.singleton "v" (NakedAtomExpr (BoolAtom True)))]))
52+ case eErr of
53+ Left err -> error (show err)
54+ Right _ -> do
55+ replicateM_ tCount (runTransaction session conn)
56+ close conn
57+ printFdCount
58+
59+runTransaction :: SessionId -> Connection -> IO ()
60+runTransaction sess conn = do
61+ --run tutd on every iteration
62+ let tutd = "update x (v:=not(@v))"
63+ case parseTutorialD tutd of
64+ Left err -> error (show err)
65+ Right parsed -> do
66+ res <- evalTutorialD sess conn UnsafeEvaluation parsed
67+ case res of
68+ DisplayErrorResult err -> error (T.unpack err)
69+ DisplayParseErrorResult _ err -> error (parseErrorPretty err)
70+ _ -> do
71+ eErr <- commit sess conn
72+ case eErr of
73+ Left err -> error (show err)
74+ Right _ -> printFdCount
75+
76+--prints out number of consumed file descriptors
77+printFdCount :: IO ()
78+#if defined(linux_HOST_OS)
79+printFdCount = do
80+ fdc <- fdCount
81+ putStrLn ("Fd count: " ++ show fdc)
82+ --getLine >> pure ()
83+#else
84+printFdCount = putStrLn "Fd count not supported on this OS."
85+#endif
86+
87+
88+fdCount :: IO Int
89+#if defined(linux_HOST_OS)
90+fdCount = do
91+ fds <- getDirectoryContents "/proc/self/fd"
92+ pure ((length fds) - 2)
93+#else
94+--not supported on non-linux
95+fdCount = pure 0
96+#endif
src/lib/ProjectM36/Client.hs+6−3
@@ -214,8 +214,6 @@ defaultRemoteConnectionInfo = RemoteProcessConnectionInfo defaultDatabaseName (c
214214-- | The 'Connection' represents either local or remote access to a database. All operations flow through the connection.
215215type ClientNodes = STMSet.Set ProcessId
216216
217−type TransactionGraphLockHandle = Handle
218−
219217-- internal structure specific to in-process connections
220218data InProcessConnectionConf = InProcessConnectionConf {
221219 ipPersistenceStrategy :: PersistenceStrategy,
@@ -225,7 +223,7 @@ data InProcessConnectionConf = InProcessConnectionConf {
225223 ipScriptSession :: Maybe ScriptSession,
226224 ipLocalNode :: LocalNode,
227225 ipTransport :: Transport, -- we hold onto this so that we can close it gracefully
228− ipLocks :: Maybe (TransactionGraphLockHandle, MVar LockFileHash) -- nothing when NoPersistence
226+ ipLocks :: Maybe (LockFile, MVar LockFileHash) -- nothing when NoPersistence
229227 }
230228
231229data RemoteProcessConnectionConf = RemoteProcessConnectionConf {
@@ -416,6 +414,7 @@ closeSession :: SessionId -> Connection -> IO ()
416414closeSession sessionId (InProcessConnection conf) =
417415 atomically $ STMMap.delete sessionId (ipSessions conf)
418416closeSession sessionId conn@(RemoteProcessConnection _) = remoteCall conn (CloseSession sessionId)
417+
419418-- | 'close' cleans up the database access connection and closes any relevant sockets.
420419close :: Connection -> IO ()
421420close (InProcessConnection conf) = do
@@ -425,6 +424,10 @@ close (InProcessConnection conf) = do
425424 pure ()
426425 closeLocalNode (ipLocalNode conf)
427426 closeTransport (ipTransport conf)
427+ let mLocks = ipLocks conf
428+ case mLocks of
429+ Nothing -> pure ()
430+ Just (lockFileH, _) -> closeLockFile lockFileH
428431
429432close conn@(RemoteProcessConnection conf) = do
430433 _ <- remoteCall conn Logout :: IO Bool
src/lib/ProjectM36/FileLock.hs+30−14
@@ -1,4 +1,4 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE CPP, NamedFieldPuns #-}
22--cross-platform file locking utilizing POSIX file locking on Unix/Linux and Windows file locking
33--hackage's System.FileLock doesn't support POSIX advisory locks nor locking file based on file descriptors, hence this needless rewrite
44module ProjectM36.FileLock where
@@ -24,6 +24,16 @@ foreign import WINDOWS_CCONV "LockFileEx" c_lockFileEx :: HANDLE -> DWORD -> DWO
2424
2525foreign import WINDOWS_CCONV "UnlockFileEx" c_unlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL
2626
27+type LockFile = Handle
28+
29+openLockFile :: FilePath -> IO LockFile
30+openLockFile path = openFile path ReadMode
31+
32+closeLockFile :: LockFile -> IO ()
33+closeLockFile file = do
34+ unlockFile file
35+ hClose file
36+
2737--swiped from System.FileLock package
2838lockFile :: Handle -> LockType -> IO ()
2939lockFile handle lock = withHandleToHANDLE handle $ \winHandle -> do
@@ -53,33 +63,39 @@ unlockFile handle = withHandleToHANDLE handle $ \winHandle -> do
5363 error ("failed to unlock database lock: " ++ show res)
5464
5565#else
66+--all of this complicated nonsense is fixed if we switch to GHC 8.2 which includes native flock support on handles
5667import qualified System.Posix.IO as P
68+import System.Posix.Types
69+import System.Posix.Files
5770
5871lockStruct :: P.LockRequest -> P.FileLock
5972lockStruct req = (req, AbsoluteSeek, 0, 0)
6073
74+newtype LockFile = LockFile Fd
75+
76+--we cannot use openFile from System.IO because it implements complicated locking which prevents opening the same file twice in write mode in the same process with no way to bypass the check.
77+openLockFile :: FilePath -> IO LockFile
78+openLockFile path =
79+ LockFile <$> P.createFile path ownerWriteMode
80+
81+closeLockFile :: LockFile -> IO ()
82+closeLockFile l@(LockFile fd) = do
83+ unlockFile l
84+ P.closeFd fd
85+
6186--blocks on lock, if necessary
62−lockFile :: Handle -> LockType -> IO ()
63−lockFile file lock = do
64− fd <- P.handleToFd file
87+lockFile :: LockFile -> LockType -> IO ()
88+lockFile (LockFile fd) lock = do
6589 let lockt = case lock of
6690 WriteLock -> P.WriteLock
6791 ReadLock -> P.ReadLock
6892 P.waitToSetLock fd (lockStruct lockt)
6993
70−unlockFile :: Handle -> IO ()
71−unlockFile file = do
72− fd <- P.handleToFd file
94+unlockFile :: LockFile -> IO ()
95+unlockFile (LockFile fd) =
7396 P.waitToSetLock fd (lockStruct P.Unlock)
7497#endif
7598
7699data LockType = ReadLock | WriteLock
77100
78−{-
79−lockFileSTM :: Handle -> LockType -> STM ()
80−lockFileSTM file lock = unsafeIOToSTM $ onException (lockFile file lock) (unlockFile file)
81−
82−unlockFileSTM :: Handle -> STM ()
83−unlockFileSTM file = unsafeIOToSTM $ unlockFile file
84−-}
85101
src/lib/ProjectM36/Transaction/Persist.hs+11−12
@@ -8,7 +8,7 @@ import ProjectM36.Persist (writeBSFileSync, DiskSync, renameSync)
88import qualified Data.Map as M
99import qualified Data.HashSet as HS
1010import qualified Data.Binary as B
11−import qualified Data.ByteString.Lazy as BS
11+--import qualified Data.ByteString as BS
1212import System.FilePath
1313import System.Directory
1414import qualified Data.Text as T
@@ -59,7 +59,7 @@ readTransaction dbdir transId mScriptSession = do
5959 return $ Left $ MissingTransactionError transId
6060 else do
6161 relvars <- readRelVars transDir
62− transInfo <- B.decode <$> BS.readFile (transactionInfoPath transDir)
62+ transInfo <- B.decodeFile (transactionInfoPath transDir)
6363 incDeps <- readIncDeps transDir
6464 typeCons <- readTypeConstructorMapping transDir
6565 sschemas <- readSubschemas transDir
@@ -89,7 +89,7 @@ writeTransaction sync dbdir trans = do
8989 writeDBCFuncs sync tempTransDir (dbcFunctions context)
9090 writeTypeConstructorMapping sync tempTransDir (typeConstructorMapping context)
9191 writeSubschemas sync tempTransDir (subschemas trans)
92− BS.writeFile (transactionInfoPath tempTransDir) (B.encode $ transactionInfo trans)
92+ B.encodeFile (transactionInfoPath tempTransDir) (transactionInfo trans)
9393 --move the temp directory to final location
9494 renameSync sync tempTransDir finalTransDir
9595 pure ()
@@ -101,13 +101,13 @@ writeRelVar sync transDir (relvarName, rel) = do
101101
102102writeRelVars :: DiskSync -> FilePath -> M.Map RelVarName Relation -> IO ()
103103writeRelVars sync transDir relvars = mapM_ (writeRelVar sync transDir) $ M.toList relvars
104−
104+
105105readRelVars :: FilePath -> IO (M.Map RelVarName Relation)
106106readRelVars transDir = do
107107 let relvarsPath = relvarsDir transDir
108108 relvarNames <- getDirectoryNames relvarsPath
109109 relvars <- mapM (\name -> do
110− rel <- B.decode <$> BS.readFile (relvarsPath </> name)
110+ rel <- B.decodeFile (relvarsPath </> name)
111111 return (T.pack name, rel)) relvarNames
112112 return $ M.fromList relvars
113113
@@ -133,7 +133,7 @@ writeAtomFunc sync transDir func = do
133133readAtomFunc :: FilePath -> AtomFunctionName -> Maybe ScriptSession -> AtomFunctions -> IO AtomFunction
134134readAtomFunc transDir funcName mScriptSession precompiledFuncs = do
135135 let atomFuncPath = atomFuncsDir transDir </> T.unpack funcName
136− (funcType, mFuncScript) <- B.decode <$> BS.readFile atomFuncPath
136+ (funcType, mFuncScript) <- B.decodeFile atomFuncPath
137137 case mFuncScript of
138138 --handle pre-compiled case- pull it from the precompiled list
139139 Nothing -> case atomFunctionForName funcName precompiledFuncs of
@@ -174,7 +174,7 @@ readDBCFuncs transDir mScriptSession = do
174174readDBCFunc :: FilePath -> DatabaseContextFunctionName -> Maybe ScriptSession -> DatabaseContextFunctions -> IO DatabaseContextFunction
175175readDBCFunc transDir funcName mScriptSession precompiledFuncs = do
176176 let dbcFuncPath = dbcFuncsDir transDir </> T.unpack funcName
177− (funcType, mFuncScript) <- B.decode <$> BS.readFile dbcFuncPath
177+ (funcType, mFuncScript) <- B.decodeFile dbcFuncPath
178178 case mFuncScript of
179179 Nothing -> case databaseContextFunctionForName funcName precompiledFuncs of
180180 Left _ -> error ("expected precompiled dbc function: " ++ T.unpack funcName)
@@ -202,8 +202,8 @@ writeIncDeps sync transDir incdeps = mapM_ (writeIncDep sync transDir) $ M.toLis
202202readIncDep :: FilePath -> IncDepName -> IO (IncDepName, InclusionDependency)
203203readIncDep transDir incdepName = do
204204 let incDepPath = incDepsDir transDir </> T.unpack incdepName
205− incDepData <- BS.readFile incDepPath
206− pure (incdepName, B.decode incDepData)
205+ incDepData <- B.decodeFile incDepPath
206+ pure (incdepName, incDepData)
207207
208208readIncDeps :: FilePath -> IO (M.Map IncDepName InclusionDependency)
209209readIncDeps transDir = do
@@ -215,8 +215,7 @@ readIncDeps transDir = do
215215readSubschemas :: FilePath -> IO Subschemas
216216readSubschemas transDir = do
217217 let sschemasPath = subschemasPath transDir
218− bytes <- BS.readFile sschemasPath
219− pure (B.decode bytes)
218+ B.decodeFile sschemasPath
220219
221220writeSubschemas :: DiskSync -> FilePath -> Subschemas -> IO ()
222221writeSubschemas sync transDir sschemas = do
@@ -230,6 +229,6 @@ writeTypeConstructorMapping sync path types = let atPath = typeConsPath path in
230229readTypeConstructorMapping :: FilePath -> IO TypeConstructorMapping
231230readTypeConstructorMapping path = do
232231 let atPath = typeConsPath path
233− B.decode <$> BS.readFile atPath
232+ B.decodeFile atPath
234233
235234
src/lib/ProjectM36/TransactionGraph/Persist.hs+9−15
@@ -10,7 +10,6 @@ import ProjectM36.FileLock
1010import System.Directory
1111import System.FilePath
1212import System.IO.Temp
13−import System.IO
1413import Data.Time.Clock.POSIX
1514import qualified Data.UUID as U
1615import qualified Data.Set as S
@@ -41,7 +40,7 @@ Persistence requires a POSIX-compliant, journaled-metadata filesystem.
4140-}
4241
4342expectedVersion :: Int
44−expectedVersion = 3
43+expectedVersion = 4
4544
4645transactionLogFileName :: FilePath
4746transactionLogFileName = "m36v" ++ show expectedVersion
@@ -71,7 +70,7 @@ checkForOtherVersions dbdir = do
7170 pure (Right ())
7271
7372
74−setupDatabaseDir :: DiskSync -> FilePath -> TransactionGraph -> IO (Either PersistenceError (Handle, LockFileHash))
73+setupDatabaseDir :: DiskSync -> FilePath -> TransactionGraph -> IO (Either PersistenceError (LockFile, LockFileHash))
7574setupDatabaseDir sync dbdir bootstrapGraph = do
7675 dbdirExists <- doesDirectoryExist dbdir
7776 eWrongVersion <- checkForOtherVersions dbdir
@@ -81,9 +80,9 @@ setupDatabaseDir sync dbdir bootstrapGraph = do
8180 m36exists <- doesFileExist (transactionLogPath dbdir)
8281 if dbdirExists && m36exists then do
8382 --no directories to write, just
84− lockFileH <- openLockFile dbdir
85− gDigest <- bracket_ (lockFile lockFileH WriteLock) (unlockFile lockFileH) (readGraphTransactionIdFileDigest dbdir)
86− pure (Right (lockFileH, gDigest))
83+ locker <- openLockFile (lockFilePath dbdir)
84+ gDigest <- bracket_ (lockFile locker WriteLock) (unlockFile locker) (readGraphTransactionIdFileDigest dbdir)
85+ pure (Right (locker, gDigest))
8786 else if not m36exists then do
8887 locks <- bootstrapDatabaseDir sync dbdir bootstrapGraph
8988 pure (Right locks)
@@ -92,19 +91,14 @@ setupDatabaseDir sync dbdir bootstrapGraph = do
9291{-
9392initialize a database directory with the graph from which to bootstrap- return lock file handle
9493-}
95−bootstrapDatabaseDir :: DiskSync -> FilePath -> TransactionGraph -> IO (Handle, LockFileHash)
94+bootstrapDatabaseDir :: DiskSync -> FilePath -> TransactionGraph -> IO (LockFile, LockFileHash)
9695bootstrapDatabaseDir sync dbdir bootstrapGraph = do
9796 createDirectory dbdir
98− lockFileH <- openLockFile dbdir
97+ locker <- openLockFile (lockFilePath dbdir)
9998 let allTransIds = map transactionId (S.toList (transactionsForGraph bootstrapGraph))
100− digest <- bracket_ (lockFile lockFileH WriteLock) (unlockFile lockFileH) (transactionGraphPersist sync dbdir allTransIds bootstrapGraph)
101− pure (lockFileH, digest)
99+ digest <- bracket_ (lockFile locker WriteLock) (unlockFile locker) (transactionGraphPersist sync dbdir allTransIds bootstrapGraph)
100+ pure (locker, digest)
102101
103−openLockFile :: FilePath -> IO Handle
104−openLockFile dbdir = do
105− lockFileH <- openFile (lockFilePath dbdir) WriteMode
106− pure lockFileH
107−
108102{-
109103incrementally updates an existing database directory
110104--algorithm:
stack.yaml+4−1
@@ -14,7 +14,7 @@ extra-deps:
1414- extended-reals-0.2.1.0
1515- gnuplot-0.5.4.1
1616- text-1.2.2.1
17−- uuid-aeson-0.1.0.0
17+- aeson-1.2.1.00
1818- distributed-process-0.6.6
1919- distributed-process-async-0.2.4
2020- distributed-process-client-server-0.2.3
@@ -43,3 +43,6 @@ extra-package-dbs: []
4343
4444# Allow a newer minor version of GHC than the snapshot specifies
4545# compiler-check: newer-minor
46+
47+allow-newer: true
48+