4db1312 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

handle exceptions in AtomFunctionBody scripts

4db1312AgentM10 years ago

project-m36.cabal+1−1

compare with master

unifiedsplit

@@ -272,7 +272,7 @@ Test-Suite test-tutoriald

272 Hs-Source-Dirs: ./src/bin, ., test

273 CPP-Options: -DPROJECTM36_VERSION="v0.1"

274

275−Test-Suite test-atomfunctionbody

275+Test-Suite test-tutoriald-atomfunctionscript

276 Default-Language: Haskell2010

277 Default-Extensions: OverloadedStrings

278 type: exitcode-stdio-1.0

src/bin/TutorialD/Interpreter/Base.hs+46−8

@@ -14,6 +14,14 @@ import System.IO

14import ProjectM36.Relation.Show.Term

15import GHC.Generics

17+displayOpResult :: TutorialDOperatorResult -> IO ()

18+displayOpResult QuitResult = return ()

19+displayOpResult (DisplayResult out) = TIO.putStrLn out

20+displayOpResult (DisplayIOResult ioout) = ioout

21+displayOpResult (DisplayErrorResult err) = TIO.hPutStrLn stderr ("ERR: " `T.append` err)

22+displayOpResult QuietSuccessResult = return ()

23+displayOpResult (DisplayRelationResult rel) = TIO.putStrLn (showRelation rel)

24+

17lexer :: Token.TokenParser ()

25lexer :: Token.TokenParser ()

18lexer = Token.makeTokenParser tutD

26lexer = Token.makeTokenParser tutD

19 where tutD = emptyDef {

27 where tutD = emptyDef {

@@ -47,6 +55,12 @@ comma = Token.comma lexer

47pipe :: Parser String

55pipe :: Parser String

48pipe = Token.symbol lexer "|"

56pipe = Token.symbol lexer "|"

58+quote :: Parser String

59+quote = Token.symbol lexer "\""

60+

61+tripleQuote :: Parser String

62+tripleQuote = Token.symbol lexer "\"\"\""

63+

50arrow :: Parser String

64arrow :: Parser String

51arrow = Token.symbol lexer "->"

65arrow = Token.symbol lexer "->"

@@ -92,18 +106,42 @@ data TutorialDOperatorResult = QuitResult |

106

93type TransactionGraphWasUpdated = Bool

107type TransactionGraphWasUpdated = Bool

108

95−displayOpResult :: TutorialDOperatorResult -> IO ()

109+{-

96−displayOpResult QuitResult = return ()

97−displayOpResult (DisplayResult out) = TIO.putStrLn out

98−displayOpResult (DisplayIOResult ioout) = ioout

99−displayOpResult (DisplayErrorResult err) = TIO.hPutStrLn stderr ("ERR: " `T.append` err)

100−displayOpResult QuietSuccessResult = return ()

101−displayOpResult (DisplayRelationResult rel) = TIO.putStrLn (showRelation rel)

102−

103quotedChar :: Parser Char

110quotedChar :: Parser Char

104quotedChar = noneOf "\""

111quotedChar = noneOf "\""

105 <|> try (string "\"\"" >> return '"')

112 <|> try (string "\"\"" >> return '"')

106

113

107quotedString :: Parser String

114quotedString :: Parser String

108quotedString = string "\"" *> many quotedChar <* string "\"" <* whiteSpace

115quotedString = string "\"" *> many quotedChar <* string "\"" <* whiteSpace

116+-}

117+escapedString :: Parser String

118+escapedString = do

119+ _ <- char '\\'

120+ let lookupAssoc = [('n',"\n"), ('\"',"\""), ('\\', "\\")]

121+ c <- oneOf "\\\"n" -- all the characters which can be escaped

122+ case lookup c lookupAssoc of

123+ Just v -> pure v

124+ Nothing -> fail "failed to handle escaped character"

125+

126+--http://stackoverflow.com/questions/24106314/parser-for-quoted-string-using-parsec

127+nonEscapedChar :: Parser Char

128+nonEscapedChar = noneOf "\\\""

129+

130+character :: Parser String

131+character = fmap return nonEscapedChar <|> escapedString

132+

133+--allow for python-style triple quoting because guessing the correct amount of escapes in different contexts is annoying

134+tripleQuotedString :: Parser String

135+tripleQuotedString = do

136+ _ <- tripleQuote

137+ manyTill anyChar (try (tripleQuote >> notFollowedBy quote))

138+

139+normalQuotedString :: Parser String

140+normalQuotedString = do

141+ _ <- quote

142+ strings <- many character

143+ _ <- quote

144+ pure (concat strings)

109

145

146+quotedString :: Parser String

147+quotedString = try tripleQuotedString <|> normalQuotedString

src/lib/ProjectM36/Client.hs+33−15

@@ -1,4 +1,4 @@

1−{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}

1+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, ScopedTypeVariables #-}

2module ProjectM36.Client

3 (ConnectionInfo(..),

4 Connection(..),

@@ -76,7 +76,7 @@ import Data.UUID.V4 (nextRandom)

76import Control.Concurrent.STM

77import Data.Word

78import Control.Distributed.Process (ProcessId, Process, receiveWait, send, match)

79−import Control.Exception (IOException)

79+import Control.Exception (IOException, SomeException(..), handle)

80import Control.Concurrent.MVar

81import qualified Data.Map as M

82import Control.Distributed.Process.Serializable (Serializable)

@@ -88,6 +88,7 @@ import ProjectM36.Sessions

88import ListT

89import Data.Binary (Binary)

90import GHC.Generics (Generic)

91+import Control.DeepSeq (force)

91--import Debug.Trace

92--import Debug.Trace

93type Hostname = String

94type Hostname = String

@@ -206,7 +207,7 @@ connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId notific

206 eLocalNode <- commonLocalNode

207 eLocalNode <- commonLocalNode

207 notificationListenerPid <- startNotificationListener notificationCallback

208 notificationListenerPid <- startNotificationListener notificationCallback

208 let dbName = remoteDBLookupName databaseName

209 let dbName = remoteDBLookupName databaseName

209− putStrLn $ show serverNodeId ++ " " ++ dbName

210+ --putStrLn $ show serverNodeId ++ " " ++ dbName

210 case eLocalNode of

211 case eLocalNode of

211 Left err -> pure (Left err)

212 Left err -> pure (Left err)

212 Right localNode -> do

213 Right localNode -> do

@@ -301,6 +302,19 @@ close (RemoteProcessConnection localNode serverProcessId) = do

301 runProcessResult localNode $ do

302 runProcessResult localNode $ do

302 call serverProcessId Logout

303 call serverProcessId Logout

303

304

305+--within the database server, we must catch and handle all exception lest they take down the database process- this handling might be different for other use-cases

306+--exceptions should generally *NOT* be thrown from any Project:M36 code paths, but third-party code such as AtomFunction scripts could conceivably throw undefined, etc.

307+

308+excMaybe :: IO (Maybe RelationalError) -> IO (Maybe RelationalError)

309+excMaybe m = handle handler m

310+ where

311+ handler (exc :: SomeException) = pure (Just (UnhandledExceptionError (show exc)))

312+

313+excEither :: IO (Either RelationalError a) -> IO (Either RelationalError a)

314+excEither m = handle handler m

315+ where

316+ handler (exc :: SomeException) = pure (Left (UnhandledExceptionError (show exc)))

317+

304runProcessResult :: LocalNode -> Process a -> IO a

318runProcessResult :: LocalNode -> Process a -> IO a

305runProcessResult localNode proc = do

319runProcessResult localNode proc = do

306 ret <- newEmptyMVar

320 ret <- newEmptyMVar

@@ -324,32 +338,36 @@ sessionForSessionId sessionId sessions = do

324

338

325-- | Execute a relational expression in the context of the session and connection. Relational expressions are queries and therefore cannot alter the database.

339-- | Execute a relational expression in the context of the session and connection. Relational expressions are queries and therefore cannot alter the database.

326executeRelationalExpr :: SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)

340executeRelationalExpr :: SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)

327−executeRelationalExpr sessionId (InProcessConnection _ _ sessions _ _) expr = atomically $ do

341+executeRelationalExpr sessionId (InProcessConnection _ _ sessions _ _) expr = excEither $ atomically $ do

328 eSession <- sessionForSessionId sessionId sessions

342 eSession <- sessionForSessionId sessionId sessions

329 case eSession of

343 case eSession of

330 Left err -> pure $ Left err

344 Left err -> pure $ Left err

331− Right (Session (DisconnectedTransaction _ context)) -> pure $ evalState (RE.evalRelationalExpr expr) context

345+ Right (Session (DisconnectedTransaction _ context)) -> case evalState (RE.evalRelationalExpr expr) context of

346+ Left err -> pure (Left err)

347+ Right rel -> pure (force (Right rel)) -- this is necessary so that any undefined/error exceptions are spit out here

332executeRelationalExpr sessionId conn@(RemoteProcessConnection _ _) relExpr = remoteCall conn (ExecuteRelationalExpr sessionId relExpr)

348executeRelationalExpr sessionId conn@(RemoteProcessConnection _ _) relExpr = remoteCall conn (ExecuteRelationalExpr sessionId relExpr)

333

349

334-- | Execute a database context expression in the context of the session and connection. Database expressions modify the current session's disconnected transaction but cannot modify the transaction graph.

350-- | Execute a database context expression in the context of the session and connection. Database expressions modify the current session's disconnected transaction but cannot modify the transaction graph.

335executeDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Maybe RelationalError)

351executeDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Maybe RelationalError)

336−executeDatabaseContextExpr sessionId (InProcessConnection _ _ sessions _ _) expr = atomically $ do

352+executeDatabaseContextExpr sessionId (InProcessConnection _ _ sessions _ _) expr = excMaybe $ atomically $ do

337 eSession <- sessionForSessionId sessionId sessions

353 eSession <- sessionForSessionId sessionId sessions

338 case eSession of

354 case eSession of

339 Left err -> pure $ Just err

355 Left err -> pure $ Just err

356+ Right session -> do

340− Right session -> case runState (RE.evalContextExpr expr) (sessionContext session) of

357+ case runState (RE.evalContextExpr expr) (sessionContext session) of

341− (Just err,_) -> return $ Just err

358+ (Just err,_) -> return $ Just err

342− (Nothing, context') -> do

359+ (Nothing, context') -> do

343− let newDiscon = DisconnectedTransaction (sessionParentId session) context'

360+ let newDiscon = DisconnectedTransaction (sessionParentId session) context'

344− newSession = Session newDiscon

361+ newSession = Session newDiscon

345− STMMap.insert newSession sessionId sessions

362+ STMMap.insert newSession sessionId sessions

346− return Nothing

363+ pure Nothing

364+

347executeDatabaseContextExpr sessionId conn@(RemoteProcessConnection _ _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr sessionId dbExpr)

365executeDatabaseContextExpr sessionId conn@(RemoteProcessConnection _ _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr sessionId dbExpr)

348

366

349-- | Execute a database context IO-monad-based expression for the given session and connection. `DatabaseContextIOExpr` modify the DatabaseContext but cannot be purely implemented.

367-- | Execute a database context IO-monad-based expression for the given session and connection. `DatabaseContextIOExpr` modify the DatabaseContext but cannot be purely implemented.

350--this is almost completely identical to executeDatabaseContextExpr above

368--this is almost completely identical to executeDatabaseContextExpr above

351executeDatabaseContextIOExpr :: SessionId -> Connection -> DatabaseContextIOExpr -> IO (Maybe RelationalError)

369executeDatabaseContextIOExpr :: SessionId -> Connection -> DatabaseContextIOExpr -> IO (Maybe RelationalError)

352−executeDatabaseContextIOExpr sessionId (InProcessConnection _ _ sessions _ scriptSession) expr = do

370+executeDatabaseContextIOExpr sessionId (InProcessConnection _ _ sessions _ scriptSession) expr = excMaybe $ do

353 eSession <- atomically $ sessionForSessionId sessionId sessions --potentially race condition due to interleaved IO?

371 eSession <- atomically $ sessionForSessionId sessionId sessions --potentially race condition due to interleaved IO?

354 case eSession of

372 case eSession of

355 Left err -> pure $ Just err

373 Left err -> pure $ Just err

@@ -390,7 +408,7 @@ executeCommitExprSTM_ oldContext newContext nodes = do

390

408

391-- | Execute a transaction graph expression in the context of the session and connection. Transaction graph operators modify the transaction graph state.

409-- | Execute a transaction graph expression in the context of the session and connection. Transaction graph operators modify the transaction graph state.

392executeGraphExpr :: SessionId -> Connection -> TransactionGraphOperator -> IO (Maybe RelationalError)

410executeGraphExpr :: SessionId -> Connection -> TransactionGraphOperator -> IO (Maybe RelationalError)

393−executeGraphExpr sessionId (InProcessConnection strat clientNodes sessions graphTvar _) graphExpr = do

411+executeGraphExpr sessionId (InProcessConnection strat clientNodes sessions graphTvar _) graphExpr = excMaybe $ do

394 freshId <- nextRandom

412 freshId <- nextRandom

395 manip <- atomically $ do

413 manip <- atomically $ do

396 eSession <- sessionForSessionId sessionId sessions

414 eSession <- sessionForSessionId sessionId sessions

src/lib/ProjectM36/Error.hs+1

@@ -69,6 +69,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

69 | NotificationNameNotInUseError NotificationName

70 | ImportError T.Text -- really? This should be broken out into some other error type- this has nothing to do with relational algebra

71 | ExportError T.Text

72+ | UnhandledExceptionError String

72 | MergeTransactionError MergeError

73 | MergeTransactionError MergeError

73 | AtomFunctionBodyScriptError AtomFunctionBodyCompilationError

74 | AtomFunctionBodyScriptError AtomFunctionBodyCompilationError

74 | MultipleErrors [RelationalError]

75 | MultipleErrors [RelationalError]

test/TutorialD/Interpreter/AtomFunctionScript.hs+31−4

@@ -4,23 +4,50 @@ import Test.HUnit

4import ProjectM36.Client

5import ProjectM36.Relation

6import ProjectM36.Base

7+import ProjectM36.Error

7import qualified Data.Vector as V

8import qualified Data.Vector as V

8import qualified Data.Map as M

9import qualified Data.Map as M

10main :: IO ()

11main :: IO ()

11main = do

12main = do

12− tcounts <- runTestTT (TestList [testBasicAtomFunction])

13+ tcounts <- runTestTT (TestList [testBasicAtomFunction,

14+ testErrorAtomFunction])

13 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

15 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

17+--add an atom function and run it

15testBasicAtomFunction :: Test

18testBasicAtomFunction :: Test

16testBasicAtomFunction = TestCase $ do

19testBasicAtomFunction = TestCase $ do

17− --add an atom function and run it

18 (sess, conn) <- dateExamplesConnection emptyNotificationCallback

20 (sess, conn) <- dateExamplesConnection emptyNotificationCallback

19− executeTutorialD sess conn "addatomfunction \"mkTest\" Int -> Int \"\\(IntAtom x:xs) -> IntAtom x\""

21+ executeTutorialD sess conn "addatomfunction \"mkTest\" Int -> Int \"\\\\(IntAtom x:xs) -> IntAtom x\""

20 let attrs = [Attribute "x" IntAtomType]

22 let attrs = [Attribute "x" IntAtomType]

21 funcAtomExpr = FunctionAtomExpr "mkTest" [NakedAtomExpr (IntAtom 3)]

23 funcAtomExpr = FunctionAtomExpr "mkTest" [NakedAtomExpr (IntAtom 3)]

22 tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]

24 tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]

23 expectedResult = mkRelationFromList (V.fromList attrs) [[IntAtom 3]]

25 expectedResult = mkRelationFromList (V.fromList attrs) [[IntAtom 3]]

24 result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)

26 result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)

26− assertEqual "simple atom function equality" expectedResult result

28+ assertEqual "simple atom function equality" expectedResult result

29+

30+--add an atom function which bombs out

31+testErrorAtomFunction :: Test

32+testErrorAtomFunction = TestCase $ do

33+ (sess, conn) <- dateExamplesConnection emptyNotificationCallback

34+ executeTutorialD sess conn "addatomfunction \"mkTest\" Int -> Int \"\"\"\\(IntAtom x:xs) -> (error (show 1) ) :: Atom\"\"\""

35+ let attrs = [Attribute "x" IntAtomType]

36+ funcAtomExpr = FunctionAtomExpr "mkTest" [NakedAtomExpr (IntAtom 3)]

37+ tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]

38+ expectedResult = Left (UnhandledExceptionError "1")

39+ result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)

40+ assertEqual "catch error exception from script" expectedResult result

41+

42+testNoArgumentAtomFunction :: Test

43+testNoArgumentAtomFunction = TestCase $ do

44+ (sess, conn) <- dateExamplesConnection emptyNotificationCallback

45+ executeTutorialD sess conn "addatomfunction \"mkTest\" Int -> Int \"\"\"\\(x :: [Atom]) -> IntAtom 5\"\"\""

46+ let attrs = [Attribute "x" IntAtomType]

47+ funcAtomExpr = FunctionAtomExpr "mkTest" []

48+ tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]

49+ expectedResult = mkRelationFromList (V.fromList attrs) [[IntAtom 5]]

50+ result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)

51+ assertEqual "no argument scripted function" expectedResult result

52+

53+