@@ -15,13 +15,6 @@ import TutorialD.Interpreter.Base
1515import ProjectM36.Client
1616import Control.Exception
1717import Data.Maybe (fromMaybe)
18−import System.IO (hPutStrLn, stderr)
19−import System.Exit
20−
21−-- | Called when the project-m36-server exits.
22−failureHandler :: Either SomeException Bool -> IO ()
23−failureHandler (Left exc) = hPutStrLn stderr ("WebSocket server encountered exception: " ++ show exc) >> exitFailure
24−failureHandler (Right boo) = hPutStrLn stderr ("WebSocket server encountered boolean failure: " ++ show boo) >> exitFailure
2518
2619websocketProxyServer :: Port -> Hostname -> WS.ServerApp
2720websocketProxyServer port host pending = do
@@ -32,39 +25,43 @@ websocketProxyServer port host pending = do
3225 let connectdbmsg = "connectdb:"
3326 if not (connectdbmsg `T.isPrefixOf` dbmsg) then unexpectedMsg >> WS.sendClose conn ("" :: T.Text)
3427 else do
35− let dbname = T.unpack $ T.drop (T.length connectdbmsg) dbmsg
36− eDbconn <- createConnection conn dbname port host
37− case eDbconn of
38− Left err -> sendError conn err
39− Right dbconn -> do
40− eSessionId <- createSessionAtHead "master" dbconn
41− case eSessionId of
28+ let dbname = T.unpack $ T.drop (T.length connectdbmsg) dbmsg
29+ bracket (createConnection conn dbname port host)
30+ (\eDBconn -> case eDBconn of
31+ Right dbconn -> close dbconn
32+ Left _ -> pure ()) $ \eDBconn -> do
33+ case eDBconn of
4234 Left err -> sendError conn err
43− Right sessionId -> do
44− --phase 2- accept tutoriald commands
45− _ <- forever $ do
46− pInfo <- promptInfo sessionId dbconn
47− sendPromptInfo pInfo conn
48− sendPromptInfo pInfo conn
49− msg <- (WS.receiveData conn) :: IO T.Text
50− let tutdprefix = "executetutd:"
51− case msg of
52− _ | tutdprefix `T.isPrefixOf` msg -> do
53− let tutdString = T.drop (T.length tutdprefix) msg
54− case parseTutorialD tutdString of
55− Left err -> handleOpResult conn dbconn (DisplayErrorResult ("parse error: " `T.append` T.pack (show err)))
56− Right parsed -> do
57− let timeoutFilter = \exc -> if exc == RequestTimeoutException
58− then Just exc
59− else Nothing
60− responseHandler = do
61− result <- evalTutorialD sessionId dbconn SafeEvaluation parsed
62− pInfo' <- promptInfo sessionId dbconn
63− sendPromptInfo pInfo' conn
64− handleOpResult conn dbconn result
65− catchJust timeoutFilter responseHandler (\_ -> handleOpResult conn dbconn (DisplayErrorResult "Request Timed Out."))
66− _ -> unexpectedMsg
67− pure ()
35+ Right dbconn -> do
36+ eSessionId <- createSessionAtHead "master" dbconn
37+ case eSessionId of
38+ Left err -> sendError conn err
39+ Right sessionId -> do
40+ --phase 2- accept tutoriald commands
41+ _ <- forever $ do
42+ pInfo <- promptInfo sessionId dbconn
43+ --figure out why sending three times during startup is necessary
44+ sendPromptInfo pInfo conn
45+ sendPromptInfo pInfo conn
46+ msg <- (WS.receiveData conn) :: IO T.Text
47+ let tutdprefix = "executetutd:"
48+ case msg of
49+ _ | tutdprefix `T.isPrefixOf` msg -> do
50+ let tutdString = T.drop (T.length tutdprefix) msg
51+ case parseTutorialD tutdString of
52+ Left err -> handleOpResult conn dbconn (DisplayErrorResult ("parse error: " `T.append` T.pack (show err)))
53+ Right parsed -> do
54+ let timeoutFilter = \exc -> if exc == RequestTimeoutException
55+ then Just exc
56+ else Nothing
57+ responseHandler = do
58+ result <- evalTutorialD sessionId dbconn SafeEvaluation parsed
59+ pInfo' <- promptInfo sessionId dbconn
60+ sendPromptInfo pInfo' conn
61+ handleOpResult conn dbconn result
62+ catchJust timeoutFilter responseHandler (\_ -> handleOpResult conn dbconn (DisplayErrorResult "Request Timed Out."))
63+ _ -> unexpectedMsg
64+ pure ()
6865
6966notificationCallback :: WS.Connection -> NotificationCallback
7067notificationCallback conn notifName evaldNotif = WS.sendTextData conn (encode (object ["notificationname" .= notifName,