fa33872 · project-m36 · git.iko.soy

ProjectM36/Client/Json.hsnew file+8

compare with master

unifiedsplit

@@ -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

5import ProjectM36.Server.RemoteCallTypes

6import ProjectM36.Base

7import ProjectM36.ConcreteTypeRep

8+import ProjectM36.Error

9+

8import Data.Aeson

10import Data.Aeson

9import Data.UUID.Aeson ()

11import Data.UUID.Aeson ()

10import Data.Proxy

12import Data.Proxy

@@ -105,3 +107,14 @@ instance FromJSON Atom where

105 error "unsupported typerep serialization"

107 error "unsupported typerep serialization"

106

108

107

109

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 @@

1{-# LANGUAGE OverloadedStrings #-}

2--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

4import Control.Monad (forever)

5import Control.Monad (forever)

5import qualified Data.Text as T

6import qualified Data.Text as T

6import qualified Network.WebSockets as WS

7import qualified Network.WebSockets as WS

7import ProjectM36.Server.RemoteCallTypes.Json ()

8import ProjectM36.Server.RemoteCallTypes.Json ()

9+import ProjectM36.Client.Json ()

8import ProjectM36.Base

10import ProjectM36.Base

9−import qualified Data.Set as S

10import Data.Aeson

11import Data.Aeson

12+import TutorialD.Interpreter

13+import TutorialD.Interpreter.Base

14+import ProjectM36.Client

11

15

12main :: IO ()

16main :: IO ()

13main = do

17main = do

@@ -17,10 +21,42 @@ main = do

17application :: WS.ServerApp

21application :: WS.ServerApp

18application pending = do

22application pending = do

19 conn <- WS.acceptRequest pending

23 conn <- WS.acceptRequest pending

24+ (sessionId, dbconn) <- createConnection conn

20 forever $ do

25 forever $ do

21 msg <- (WS.receiveData conn) :: IO T.Text

26 msg <- (WS.receiveData conn) :: IO T.Text

27+ let tutdprefix = "executetutd:"

22 case msg of

28 case msg of

23− "db" -> WS.sendTextData conn (encode (Project (AttributeNames (S.fromList ["spam1", "spam2"])) (RelationVariable "elgringo")))

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

24− str -> WS.sendTextData conn str

36+ _ -> WS.sendTextData conn ("message not expected" :: T.Text)

25 return ()

37 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 @@

20

21function setStatus(text)

22{

23− newtext = document.createTextNode(text);

23+ var newtext = document.createTextNode(text);

24− statusnode = document.getElementById("status");

24+ var statusnode = document.getElementById("status");

25 while( statusnode.firstChild ) {

26 statusnode.removeChild( statusnode.firstChild );

27 }

28 statusnode.appendChild(newtext);

29}

30+

31+function execTutorialD()

32+{

33+ var tutd = document.getElementById("tutd").value

34+ socket.send("executetutd:" + tutd)

35+}

30

36

31</script>

37</script>

32</head>

38</head>

33<body>

39<body>

34<p>Status:<span id="status">Fresh</span></p>

40<p>Status:<span id="status">Fresh</span></p>

35−

41+<p><input type="text" id="tutd"/><input type="submit" onclick="execTutorialD();"/>

36</body>

42</body>

37</html>

43</html>

TutorialD/Interpreter.hs+1−1

@@ -85,7 +85,7 @@ evalTutorialD sessionId conn expr = case expr of

85 opResult <- evalROGraphOp sessionId conn execOp

86 case opResult of

87 Left err -> barf err

88− Right rel -> return $ DisplayResult $ showRelation rel

88+ Right rel -> pure (DisplayRelationResult rel)

89

90 (ImportRelVarOp execOp@(RelVarDataImportOperator relVarName _ _)) -> do

91 -- collect attributes from relvar name

TutorialD/Interpreter/Base.hs+6−1

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

1−{-# LANGUAGE OverloadedStrings #-}

1+{-# LANGUAGE OverloadedStrings, DeriveGeneric #-}

2module TutorialD.Interpreter.Base where

3import Text.Parsec

4import Text.Parsec.String

@@ -11,6 +11,8 @@ import qualified Data.Vector as V

11import qualified Data.Text.IO as TIO

12import System.IO

13import ProjectM36.DataTypes.Primitive

14+import ProjectM36.Relation.Show.Term

15+import GHC.Generics

14

16

15lexer :: Token.TokenParser ()

17lexer :: Token.TokenParser ()

16lexer = Token.makeTokenParser tutD

18lexer = Token.makeTokenParser tutD

@@ -91,8 +93,10 @@ showRelationAttributes attrs = "{" `T.append` T.concat (L.intersperse ", " $ map

91data TutorialDOperatorResult = QuitResult |

93data TutorialDOperatorResult = QuitResult |

92 DisplayResult StringType |

94 DisplayResult StringType |

93 DisplayIOResult (IO ()) |

95 DisplayIOResult (IO ()) |

96+ DisplayRelationResult Relation |

94 DisplayErrorResult StringType |

97 DisplayErrorResult StringType |

95 QuietSuccessResult

98 QuietSuccessResult

99+ deriving (Generic)

96

100

97type TransactionGraphWasUpdated = Bool

101type TransactionGraphWasUpdated = Bool

98

102

@@ -102,6 +106,7 @@ displayOpResult (DisplayResult out) = TIO.putStrLn out

102displayOpResult (DisplayIOResult ioout) = ioout

106displayOpResult (DisplayIOResult ioout) = ioout

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

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

104displayOpResult QuietSuccessResult = return ()

108displayOpResult QuietSuccessResult = return ()

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

105

110

106quotedChar :: Parser Char

111quotedChar :: Parser Char

107quotedChar = noneOf "\""

112quotedChar = noneOf "\""

TutorialD/Interpreter/RODatabaseContextOperator.hs+2−4

@@ -9,7 +9,6 @@ import TutorialD.Interpreter.RelationalExpr

9import TutorialD.Interpreter.DatabaseContextExpr

10import Control.Monad.State

11import qualified Data.Text as T

12−import ProjectM36.Relation.Show.Term

13import ProjectM36.Relation.Show.Gnuplot

12import ProjectM36.Relation.Show.Gnuplot

14import qualified Data.Map as M

13import qualified Data.Map as M

15import Data.Maybe

14import Data.Maybe

@@ -83,13 +82,13 @@ evalRODatabaseContextOp sessionId conn (ShowRelationType expr) = do

83 res <- C.typeForRelationalExpr sessionId conn expr

82 res <- C.typeForRelationalExpr sessionId conn expr

84 case res of

83 case res of

85 Left err -> pure $ DisplayErrorResult $ T.pack (show err)

84 Left err -> pure $ DisplayErrorResult $ T.pack (show err)

86− Right rel -> pure $ DisplayResult $ showRelation rel

85+ Right rel -> pure $ DisplayRelationResult rel

87

86

88evalRODatabaseContextOp sessionId conn (ShowRelation expr) = do

87evalRODatabaseContextOp sessionId conn (ShowRelation expr) = do

89 res <- C.executeRelationalExpr sessionId conn expr

88 res <- C.executeRelationalExpr sessionId conn expr

90 case res of

89 case res of

91 Left err -> pure $ DisplayErrorResult $ T.pack (show err)

90 Left err -> pure $ DisplayErrorResult $ T.pack (show err)

92− Right rel -> pure $ DisplayResult $ showRelation rel

91+ Right rel -> pure $ DisplayRelationResult rel

93

92

94evalRODatabaseContextOp sessionId conn (PlotRelation expr) = do

93evalRODatabaseContextOp sessionId conn (PlotRelation expr) = do

95 res <- C.executeRelationalExpr sessionId conn expr

94 res <- C.executeRelationalExpr sessionId conn expr

@@ -126,7 +125,6 @@ evalRODatabaseContextOp sessionId conn ShowRelationVariables = do

126 case eRel of

125 case eRel of

127 Left err -> pure $ DisplayErrorResult (T.pack (show err))

126 Left err -> pure $ DisplayErrorResult (T.pack (show err))

128 Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel))

127 Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel))

129−

130

128

131evalRODatabaseContextOp _ _ (Quit) = pure QuitResult

129evalRODatabaseContextOp _ _ (Quit) = pure QuitResult

132

130

project-m36.cabal+2

@@ -611,6 +611,8 @@ Executable project-m36-websocket-server

611 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

612 Main-Is: ProjectM36/Server/WebSocket.hs

613 GHC-Options: -Wall

614+ CPP-Options: -DPROJECTM36_VERSION="v0.1"

615+ Default-Extensions: OverloadedStrings

614 if os(windows)

616 if os(windows)

615 Build-Depends: Win32 >= 2.3 && < 2.4

617 Build-Depends: Win32 >= 2.3 && < 2.4

616 Other-Modules: ProjectM36.Win32Handle

618 Other-Modules: ProjectM36.Win32Handle