git.iko.soy/project-m36
on master help sign in
WIP working tutd execution- needs client-side display
commitfa33872ee628f53c7bb4e816e22e3e64ce9eda39 authorAgentM <agentm@themactionfaction.com> dateSun 24 Jul 2016, 22:19 (10 years ago) parenteaac481
8 files changed+82−14
compare with master
unifiedsplit
ProjectM36/Client/Json.hs+8 ProjectM36/Server/RemoteCallTypes/Json.hs+13 ProjectM36/Server/WebSocket.hs+41−5 ProjectM36/Server/websocket-test.html+9−3 TutorialD/Interpreter.hs+1−1 TutorialD/Interpreter/Base.hs+6−1 TutorialD/Interpreter/RODatabaseContextOperator.hs+2−4 project-m36.cabal+2
ProjectM36/Client/Json.hsnew file+8
@@ -0,0 +1,8 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+module ProjectM36.Client.Json where
3+import Data.Aeson
4+import ProjectM36.Server.RemoteCallTypes.Json ()
5+import ProjectM36.Client
6+
7+instance ToJSON EvaluatedNotification
8+instance FromJSON EvaluatedNotification
ProjectM36/Server/RemoteCallTypes/Json.hs+13
@@ -5,6 +5,8 @@ module ProjectM36.Server.RemoteCallTypes.Json where
55import ProjectM36.Server.RemoteCallTypes
66import ProjectM36.Base
77import ProjectM36.ConcreteTypeRep
8+import ProjectM36.Error
9+
810import Data.Aeson
911import Data.UUID.Aeson ()
1012import Data.Proxy
@@ -105,3 +107,14 @@ instance FromJSON Atom where
105107 error "unsupported typerep serialization"
106108
107109
110+instance ToJSON Notification
111+instance FromJSON Notification
112+
113+instance ToJSON RelationalError
114+instance FromJSON RelationalError
115+
116+instance ToJSON MergeError
117+instance FromJSON MergeError
118+
119+instance ToJSON MergeStrategy
120+instance FromJSON MergeStrategy
ProjectM36/Server/WebSocket.hs+41−5
@@ -1,13 +1,17 @@
11{-# LANGUAGE OverloadedStrings #-}
22--module ProjectM36.Server.WebSocket where
3−
3+-- while the tutd client performs TutorialD parsing on the client, the websocket server will pass tutd to be parsed and executed on the server- otherwise I have to pull in ghcjs as a dependency to allow client-side parsing- that's not appealing because then the frontend is not language-agnostic, but this could change in the future, perhaps by sending different messages over the websocket
4+-- ideally, the wire protocol should not be exposed to a straight string-based API ala SQL, so we could make perhaps a javascript DSL which compiles to the necessary JSON- anaylyze tradeoffs
45import Control.Monad (forever)
56import qualified Data.Text as T
67import qualified Network.WebSockets as WS
78import ProjectM36.Server.RemoteCallTypes.Json ()
9+import ProjectM36.Client.Json ()
810import ProjectM36.Base
9−import qualified Data.Set as S
1011import Data.Aeson
12+import TutorialD.Interpreter
13+import TutorialD.Interpreter.Base
14+import ProjectM36.Client
1115
1216main :: IO ()
1317main = do
@@ -17,10 +21,42 @@ main = do
1721application :: WS.ServerApp
1822application pending = do
1923 conn <- WS.acceptRequest pending
24+ (sessionId, dbconn) <- createConnection conn
2025 forever $ do
2126 msg <- (WS.receiveData conn) :: IO T.Text
27+ let tutdprefix = "executetutd:"
2228 case msg of
23− "db" -> WS.sendTextData conn (encode (Project (AttributeNames (S.fromList ["spam1", "spam2"])) (RelationVariable "elgringo")))
24− str -> WS.sendTextData conn str
29+ _ | tutdprefix `T.isPrefixOf` msg -> do
30+ let tutdString = T.drop (T.length tutdprefix) msg
31+ case parseTutorialD (T.unpack tutdString) of
32+ Left err -> handleOpResult conn (DisplayErrorResult ("parse error: " `T.append` T.pack (show err)))
33+ Right parsed -> do
34+ result <- evalTutorialD sessionId dbconn parsed
35+ handleOpResult conn result
36+ _ -> WS.sendTextData conn ("message not expected" :: T.Text)
2537 return ()
26−
38+
39+notificationCallback :: WS.Connection -> NotificationCallback
40+notificationCallback conn notifName evaldNotif = WS.sendTextData conn (encode (object ["notificationname" .= notifName,
41+ "evaldnotification" .= evaldNotif
42+ ]))
43+
44+--this creates a new database for each connection- perhaps not what we want (?)
45+createConnection :: WS.Connection -> IO (SessionId, Connection)
46+createConnection wsconn = do
47+ eConn <- connectProjectM36 (InProcessConnectionInfo NoPersistence (notificationCallback wsconn))
48+ case eConn of
49+ Left err -> error $ "failed to create database" ++ show err
50+ Right conn -> do
51+ eSessionId <- createSessionAtHead "master" conn
52+ case eSessionId of
53+ Left err -> error $ "failed to create connection on master branch" ++ show err
54+ Right sessionId -> pure (sessionId, conn)
55+
56+handleOpResult :: WS.Connection -> TutorialDOperatorResult -> IO ()
57+handleOpResult conn QuitResult = WS.sendClose conn ("close" :: T.Text)
58+handleOpResult conn (DisplayResult out) = WS.sendTextData conn (encode (object ["display" .= out]))
59+handleOpResult _ (DisplayIOResult ioout) = ioout
60+handleOpResult conn (DisplayErrorResult err) = WS.sendTextData conn (encode (object ["displayerror" .= err]))
61+handleOpResult conn QuietSuccessResult = WS.sendTextData conn (encode (object ["acknowledged" .= True]))
62+handleOpResult conn (DisplayRelationResult rel) = WS.sendTextData conn (encode (object ["displayrelation" .= rel]))
ProjectM36/Server/websocket-test.html+9−3
@@ -20,18 +20,24 @@
2020
2121function setStatus(text)
2222{
23− newtext = document.createTextNode(text);
24− statusnode = document.getElementById("status");
23+ var newtext = document.createTextNode(text);
24+ var statusnode = document.getElementById("status");
2525 while( statusnode.firstChild ) {
2626 statusnode.removeChild( statusnode.firstChild );
2727 }
2828 statusnode.appendChild(newtext);
2929}
30+
31+function execTutorialD()
32+{
33+ var tutd = document.getElementById("tutd").value
34+ socket.send("executetutd:" + tutd)
35+}
3036
3137</script>
3238</head>
3339<body>
3440<p>Status:<span id="status">Fresh</span></p>
35−
41+<p><input type="text" id="tutd"/><input type="submit" onclick="execTutorialD();"/>
3642</body>
3743</html>
TutorialD/Interpreter.hs+1−1
@@ -85,7 +85,7 @@ evalTutorialD sessionId conn expr = case expr of
8585 opResult <- evalROGraphOp sessionId conn execOp
8686 case opResult of
8787 Left err -> barf err
88− Right rel -> return $ DisplayResult $ showRelation rel
88+ Right rel -> pure (DisplayRelationResult rel)
8989
9090 (ImportRelVarOp execOp@(RelVarDataImportOperator relVarName _ _)) -> do
9191 -- collect attributes from relvar name
TutorialD/Interpreter/Base.hs+6−1
@@ -1,4 +1,4 @@
1−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings, DeriveGeneric #-}
22module TutorialD.Interpreter.Base where
33import Text.Parsec
44import Text.Parsec.String
@@ -11,6 +11,8 @@ import qualified Data.Vector as V
1111import qualified Data.Text.IO as TIO
1212import System.IO
1313import ProjectM36.DataTypes.Primitive
14+import ProjectM36.Relation.Show.Term
15+import GHC.Generics
1416
1517lexer :: Token.TokenParser ()
1618lexer = Token.makeTokenParser tutD
@@ -91,8 +93,10 @@ showRelationAttributes attrs = "{" `T.append` T.concat (L.intersperse ", " $ map
9193data TutorialDOperatorResult = QuitResult |
9294 DisplayResult StringType |
9395 DisplayIOResult (IO ()) |
96+ DisplayRelationResult Relation |
9497 DisplayErrorResult StringType |
9598 QuietSuccessResult
99+ deriving (Generic)
96100
97101type TransactionGraphWasUpdated = Bool
98102
@@ -102,6 +106,7 @@ displayOpResult (DisplayResult out) = TIO.putStrLn out
102106displayOpResult (DisplayIOResult ioout) = ioout
103107displayOpResult (DisplayErrorResult err) = TIO.hPutStrLn stderr ("ERR: " `T.append` err)
104108displayOpResult QuietSuccessResult = return ()
109+displayOpResult (DisplayRelationResult rel) = TIO.putStrLn (showRelation rel)
105110
106111quotedChar :: Parser Char
107112quotedChar = noneOf "\""
TutorialD/Interpreter/RODatabaseContextOperator.hs+2−4
@@ -9,7 +9,6 @@ import TutorialD.Interpreter.RelationalExpr
99import TutorialD.Interpreter.DatabaseContextExpr
1010import Control.Monad.State
1111import qualified Data.Text as T
12−import ProjectM36.Relation.Show.Term
1312import ProjectM36.Relation.Show.Gnuplot
1413import qualified Data.Map as M
1514import Data.Maybe
@@ -83,13 +82,13 @@ evalRODatabaseContextOp sessionId conn (ShowRelationType expr) = do
8382 res <- C.typeForRelationalExpr sessionId conn expr
8483 case res of
8584 Left err -> pure $ DisplayErrorResult $ T.pack (show err)
86− Right rel -> pure $ DisplayResult $ showRelation rel
85+ Right rel -> pure $ DisplayRelationResult rel
8786
8887evalRODatabaseContextOp sessionId conn (ShowRelation expr) = do
8988 res <- C.executeRelationalExpr sessionId conn expr
9089 case res of
9190 Left err -> pure $ DisplayErrorResult $ T.pack (show err)
92− Right rel -> pure $ DisplayResult $ showRelation rel
91+ Right rel -> pure $ DisplayRelationResult rel
9392
9493evalRODatabaseContextOp sessionId conn (PlotRelation expr) = do
9594 res <- C.executeRelationalExpr sessionId conn expr
@@ -126,7 +125,6 @@ evalRODatabaseContextOp sessionId conn ShowRelationVariables = do
126125 case eRel of
127126 Left err -> pure $ DisplayErrorResult (T.pack (show err))
128127 Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel))
129−
130128
131129evalRODatabaseContextOp _ _ (Quit) = pure QuitResult
132130
project-m36.cabal+2
@@ -611,6 +611,8 @@ Executable project-m36-websocket-server
611611 Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, distributed-process, distributed-process-extras, distributed-process-client-server, uuid, stm, deepseq, deepseq-generics, binary, unix, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, parsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, persistent, aeson, path-pieces, either, conduit, http-api-data, template-haskell, persistent-template, websockets, aeson, uuid-aeson
612612 Main-Is: ProjectM36/Server/WebSocket.hs
613613 GHC-Options: -Wall
614+ CPP-Options: -DPROJECTM36_VERSION="v0.1"
615+ Default-Extensions: OverloadedStrings
614616 if os(windows)
615617 Build-Depends: Win32 >= 2.3 && < 2.4
616618 Other-Modules: ProjectM36.Win32Handle