@@ -35,7 +35,7 @@ main = do
3535 --this built-in server is apparently not meant for production use, but it's easier to test than starting up the wai or snap interfaces
3636 putStrLn "listening on 8888"
3737 WS.runServer "0.0.0.0" 8888 (websocketProxyServer serverPort serverHost)
38−
38+
3939websocketProxyServer :: Port -> Hostname -> WS.ServerApp
4040websocketProxyServer port host pending = do
4141 conn <- WS.acceptRequest pending
@@ -46,21 +46,28 @@ websocketProxyServer port host pending = do
4646 if not (connectdbmsg `T.isPrefixOf` dbmsg) then unexpectedMsg >> WS.sendClose conn ("" :: T.Text)
4747 else do
4848 let dbname = T.unpack $ T.drop (T.length connectdbmsg) dbmsg
49− (sessionId, dbconn) <- createConnection conn dbname port host
50− --phase 2- accept tutoriald commands
51− _ <- forever $ do
52− msg <- (WS.receiveData conn) :: IO T.Text
53− let tutdprefix = "executetutd:"
54− case msg of
55− _ | tutdprefix `T.isPrefixOf` msg -> do
56− let tutdString = T.drop (T.length tutdprefix) msg
57− case parseTutorialD (T.unpack tutdString) of
58− Left err -> handleOpResult conn dbconn (DisplayErrorResult ("parse error: " `T.append` T.pack (show err)))
59− Right parsed -> do
60− result <- evalTutorialD sessionId dbconn parsed
61− handleOpResult conn dbconn result
62− _ -> unexpectedMsg
63− pure ()
49+ eDbconn <- createConnection conn dbname port host
50+ case eDbconn of
51+ Left err -> sendError conn err
52+ Right dbconn -> do
53+ eSessionId <- createSessionAtHead "master" dbconn
54+ case eSessionId of
55+ Left err -> sendError conn err
56+ Right sessionId -> do
57+ --phase 2- accept tutoriald commands
58+ _ <- forever $ do
59+ msg <- (WS.receiveData conn) :: IO T.Text
60+ let tutdprefix = "executetutd:"
61+ case msg of
62+ _ | tutdprefix `T.isPrefixOf` msg -> do
63+ let tutdString = T.drop (T.length tutdprefix) msg
64+ case parseTutorialD (T.unpack tutdString) of
65+ Left err -> handleOpResult conn dbconn (DisplayErrorResult ("parse error: " `T.append` T.pack (show err)))
66+ Right parsed -> do
67+ result <- evalTutorialD sessionId dbconn parsed
68+ handleOpResult conn dbconn result
69+ _ -> unexpectedMsg
70+ pure ()
6471
6572notificationCallback :: WS.Connection -> NotificationCallback
6673notificationCallback conn notifName evaldNotif = WS.sendTextData conn (encode (object ["notificationname" .= notifName,
@@ -68,17 +75,12 @@ notificationCallback conn notifName evaldNotif = WS.sendTextData conn (encode (o
6875 ]))
6976
7077--this creates a new database for each connection- perhaps not what we want (?)
71−createConnection :: WS.Connection -> DatabaseName -> Port -> Hostname -> IO (SessionId, Connection)
72−createConnection wsconn dbname port host = do
73− eConn <- connectProjectM36 (RemoteProcessConnectionInfo dbname (createNodeId host port) (notificationCallback wsconn))
74− case eConn of
75− Left err -> error $ "failed to connect to database" ++ show err
76− Right conn -> do
77− eSessionId <- createSessionAtHead "master" conn
78− case eSessionId of
79− Left err -> error $ "failed to create connection on master branch" ++ show err
80− Right sessionId -> pure (sessionId, conn)
81−
78+createConnection :: WS.Connection -> DatabaseName -> Port -> Hostname -> IO (Either ConnectionError Connection)
79+createConnection wsconn dbname port host = connectProjectM36 (RemoteProcessConnectionInfo dbname (createNodeId host port) (notificationCallback wsconn))
80+
81+sendError :: (ToJSON a) => WS.Connection -> a -> IO ()
82+sendError conn err = WS.sendTextData conn (encode (object ["displayerror" .= err]))
83+
8284handleOpResult :: WS.Connection -> Connection -> TutorialDOperatorResult -> IO ()
8385handleOpResult conn db QuitResult = WS.sendClose conn ("close" :: T.Text) >> close db
8486handleOpResult conn _ (DisplayResult out) = WS.sendTextData conn (encode (object ["display" .= out]))