652414b · project-m36 · git.iko.soy

git.iko.soy/project-m36

WIP major progress in extricating Data.Binary and distributed-process

not compiling

commit652414b63272ffc995d1b74adc8ef6666c812bc7 authorAgentM <agentm@themactionfaction.com> dateSun 20 Dec 2020, 22:22 (6 years ago) parent2af128d

23 files changed+340−351

compare with master

unifiedsplit

cabal.project+2−2

@@ -11,9 +11,9 @@ source-repository-package

1111source-repository-package

1212 type: git

1313 location: https://github.com/agentm/curryer.git

14− tag: 08578c17071c61ce59dbc6cb442c7ec17aeb1294

14+ tag: f67c45d1bfcb753d32ed3fe51b8e07b4c021c9bb

1515

1616source-repository-package

1717 type: git

1818 location: https://github.com/composewell/streamly.git

19− tag: e218fb9d8f4263fd69d32a2ff318bac0e179c642

19+ tag: ac3af8749194f1788704dda8667d0b3807075cc2

project-m36.cabal+1−4

@@ -34,7 +34,7 @@ Flag haskell-scripting

3434 Default: True

3535

3636Library

37− Build-Depends: base>=4.8 && < 4.15, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, binary, filepath, zlib, directory, vector-binary-instances, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, network-transport, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, distributed-process-client-server >= 0.2.3, distributed-process >= 0.7.4, distributed-process-extras >= 0.3.2, distributed-process-async >= 0.2.4.1, network-transport-tcp >= 0.6.0, network-transport, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.3, winery, curryer, network

37+ Build-Depends: base>=4.8 && < 4.15, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, network-transport, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, distributed-process-client-server >= 0.2.3, distributed-process >= 0.7.4, distributed-process-extras >= 0.3.2, distributed-process-async >= 0.2.4.1, network-transport-tcp >= 0.6.0, network-transport, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.3, winery, curryer, network

3838 if flag(haskell-scripting)

3939 Build-Depends: ghc >= 8.2 && < 8.11

4040 CPP-Options: -DPM36_HASKELL_SCRIPTING

@@ -157,13 +157,11 @@ Executable tutd

157157 MonadRandom, MonadRandom,

158158 vector,

159159 text,

160− vector-binary-instances,

161160 time,

162161 hashable-time,

163162 bytestring,

164163 stm,

165164 deepseq,

166− binary,

167165 data-interval,

168166 parallel,

169167 cassava,

@@ -212,7 +210,6 @@ Executable project-m36-server

212210 Build-Depends: base,

213211 ghc-paths,

214212 project-m36,

215− binary,

216213 transformers,

217214 temporary,

218215 data-interval,

src/lib/ProjectM36/AtomFunction.hs+1−2

@@ -1,7 +1,7 @@

11{-# LANGUAGE CPP #-}

22module ProjectM36.AtomFunction where

33import ProjectM36.Base

4−import ProjectM36.Serialise.Base

4+import ProjectM36.Serialise.Base ()

55import ProjectM36.Error

66import ProjectM36.Relation

77import ProjectM36.AtomType

@@ -11,7 +11,6 @@ import qualified ProjectM36.Attribute as A

1111import qualified Data.HashSet as HS

1212import qualified Data.Text as T

1313import qualified Data.ByteString.Lazy as BL

14−import Data.Binary as B

1514import Codec.Winery

1615

1716foldAtomFuncType :: AtomType -> AtomType -> [AtomType]

src/lib/ProjectM36/Atomable.hs−17

@@ -21,19 +21,6 @@ import Data.Proxy

2121import qualified Data.List.NonEmpty as NE

2222import Codec.Winery

2323

24−--also add haskell scripting atomable support

25−--rename this module to Atomable along with test

26−

27−{-

28−data Test1T = Test1C Int

29− deriving (Generic, Show, Eq, Binary, NFData, Atomable)

30−

31−data Test2T = Test2C Int Int

32− deriving (Generic, Show, Eq, Binary, NFData, Atomable)

33−

34−data Test3T = Test3Ca | Test3Cb

35− deriving (Generic, Show, Eq, Binary, NFData, Atomable)

36−-}

3724-- | All database values ("atoms") adhere to the 'Atomable' typeclass. This class is derivable allowing new datatypes to be easily marshaling between Haskell values and database values.

3825class (Eq a, NFData a, Serialise a, Show a) => Atomable a where

3926 toAtom :: a -> Atom

@@ -165,10 +152,6 @@ instance Atomable a => Atomable (NE.NonEmpty a) where

165152 toAtomType _ = ConstructedAtomType "NonEmptyList" (M.singleton "a" (toAtomType (Proxy :: Proxy a)))

166153 toAddTypeExpr _ = NoOperation

167154

168−#if !MIN_VERSION_binary(0,8,4)

169−instance Binary a => Binary (NE.NonEmpty a)

170−#endif

171−

172155-- Generics

173156class AtomableG g where

174157 --type AtomTG g

src/lib/ProjectM36/Base.hs−2

@@ -18,14 +18,12 @@ import GHC.Stack

1818import qualified Data.Vector as V

1919import qualified Data.List as L

2020import Data.Text (Text,unpack)

21−import Data.Vector.Binary()

2221import Data.Time.Clock

2322import Data.Hashable.Time ()

2423import Data.Time.Calendar (Day)

2524import Data.Typeable

2625import Data.ByteString (ByteString)

2726import qualified Data.List.NonEmpty as NE

28−--import Codec.Winery

2927

3028type StringType = Text

3129

src/lib/ProjectM36/Client.hs+27−26

@@ -43,6 +43,7 @@ module ProjectM36.Client

4343 defaultDatabaseName,

4444 defaultRemoteConnectionInfo,

4545 defaultHeadName,

46+ addClientNode,

4647 PersistenceStrategy(..),

4748 RelationalExpr,

4849 RelationalExprBase(..),

@@ -104,6 +105,7 @@ module ProjectM36.Client

104105 ) where

105106import ProjectM36.Base hiding (inclusionDependencies) --defined in this module as well

106107import qualified ProjectM36.Base as B

108+import ProjectM36.Serialise.Error ()

107109import ProjectM36.Error

108110import ProjectM36.Atomable

109111import ProjectM36.AtomFunction as AF

@@ -124,6 +126,7 @@ import ProjectM36.TransGraphRelationalExpression as TGRE (TransGraphRelationalEx

124126import ProjectM36.Persist (DiskSync(..))

125127import ProjectM36.FileLock

126128import ProjectM36.NormalizeExpr

129+import ProjectM36.Server.Types

127130import ProjectM36.Notifications

128131import ProjectM36.Server.RemoteCallTypes

129132import qualified ProjectM36.DisconnectedTransaction as Discon

@@ -154,18 +157,14 @@ import GHC.Generics (Generic)

154157import Control.DeepSeq (force)

155158import System.IO

156159import Data.Time.Clock

157−import Data.Typeable

158160import qualified Network.RPC.Curryer.Client as RPC

159161import qualified Network.RPC.Curryer.Server as RPC

160−import Network.Socket (PortNumber, AddrInfo(..), getAddrInfo, defaultHints, AddrInfoFlag(..), SocketType(..), ServiceName, hostAddressToTuple, SockAddr(..))

161−import Data.Word

162+import Network.Socket (Socket, AddrInfo(..), getAddrInfo, defaultHints, AddrInfoFlag(..), SocketType(..), ServiceName, hostAddressToTuple, SockAddr(..))

162163

163164type Hostname = String

164165

165166type Port = Word16

166167

167−type DatabaseName = String

168−

169168-- | The type for notifications callbacks in the client. When a registered notification fires due to a changed relational expression evaluation, the server propagates the notifications to the clients in the form of the callback.

170169type NotificationCallback = NotificationName -> EvaluatedNotification -> IO ()

171170

@@ -226,22 +225,7 @@ defaultRemoteConnectionInfo =

226225defaultServerHostname :: Hostname

227226defaultServerHostname = "localhost"

228227

229−-- | The 'Connection' represents either local or remote access to a database. All operations flow through the connection.

230−type ClientNodes = StmSet.Set RPCConnection -- not correct- we need an object to represent all client connection on the server side - this is missing in Curryer

231−

232−-- internal structure specific to in-process connections

233−data InProcessConnectionConf = InProcessConnectionConf {

234− ipPersistenceStrategy :: PersistenceStrategy,

235− ipClientNodes :: ClientNodes,

236− ipSessions :: Sessions,

237− ipTransactionGraph :: TVar TransactionGraph,

238− ipScriptSession :: Maybe ScriptSession,

239− ipLocks :: Maybe (LockFile, MVar LockFileHash) -- nothing when NoPersistence

240− }

241−

242−data RemoteConnectionConf = RemoteConnectionConf {

243− rConn :: RPCConnection

244− }

228+data RemoteConnectionConf = RemoteConnectionConf RPC.Connection

245229

246230data Connection = InProcessConnection InProcessConnectionConf |

247231 RemoteConnection RemoteConnectionConf

@@ -291,8 +275,7 @@ connectProjectM36 (InProcessConnectionInfo strat notificationCallback ghcPkgPath

291275 MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshGraph notificationCallback ghcPkgPaths

292276 CrashSafePersistence dbdir -> connectPersistentProjectM36 strat FsyncDiskSync dbdir freshGraph notificationCallback ghcPkgPaths

293277

294−connectProjectM36 (RemoteConnectionInfo databaseName hostName servicePort notificationCallback) = do

295− --putStrLn $ "Connecting to " ++ show serverNodeId ++ " " ++ dbName

278+connectProjectM36 (RemoteConnectionInfo dbName hostName servicePort notificationCallback) = do

296279 --TODO- add notification callback thread

297280 let resolutionHints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV],

298281 addrSocketType = Stream

@@ -303,9 +286,16 @@ connectProjectM36 (RemoteConnectionInfo databaseName hostName servicePort notifi

303286 addrInfo:_ -> do

304287 --supports IPv4 only for now

305288 let (SockAddrInet port addr) = addrAddress addrInfo

306− conn <- RPC.connect (const (pure ())) (hostAddressToTuple addr) port

289+-- TODO missing async callback

290+ conn <- RPC.connect [] (hostAddressToTuple addr) port

291+ eRet <- RPC.call conn (Login dbName)

292+-- TODO handle connection errors

293+ case eRet of

294+ Left err -> error (show err)

295+ Right False -> error "wtf"

296+ Right True ->

307297 --TODO handle connection errors!

308− pure (Right (RemoteConnection (RemoteConnectionConf conn)))

298+ pure (Right (RemoteConnection (RemoteConnectionConf conn)))

309299 {-

310300 mServerProcessId <- whereisRemote serverNodeId dbName

311301 case mServerProcessId of

@@ -319,6 +309,12 @@ connectProjectM36 (RemoteConnectionInfo databaseName hostName servicePort notifi

319309 takeMVar connStatus

320310-}

321311

312+addClientNode :: DatabaseName ->Connection -> RPC.Locking Socket -> IO ()

313+addClientNode _ (RemoteConnection _) _ = error "addClientNode called on remote connection"

314+addClientNode dbName (InProcessConnection conf) lockSock = atomically (StmSet.insert clientInfo (ipClientNodes conf))

315+ where

316+ clientInfo = ClientInfo dbName lockSock

317+

322318connectPersistentProjectM36 :: PersistenceStrategy ->

323319 DiskSync ->

324320 FilePath ->

@@ -441,7 +437,12 @@ safeLogin login procId = do

441437

442438remoteCall :: (Serialise a, Serialise b) => Connection -> a -> IO b

443439remoteCall (InProcessConnection _ ) _ = error "remoteCall called on local connection"

444−remoteCall (RemoteConnection conf) arg = error "not implemented"

440+remoteCall (RemoteConnection (RemoteConnectionConf rpcConn)) arg = do

441+ eRet <- RPC.call rpcConn arg

442+ case eRet of

443+ Left err -> error ("connection died " <> show err) --TODO: throw some more specific exceptions

444+ Right val -> pure val

445+

445446

446447

447448sessionForSessionId :: SessionId -> Sessions -> STM (Either RelationalError Session)

src/lib/ProjectM36/DataFrame.hs−3

@@ -4,7 +4,6 @@ module ProjectM36.DataFrame where

44import ProjectM36.Base

55import ProjectM36.Attribute as A

66import ProjectM36.Error

7−import ProjectM36.Serialise.Base

87import qualified ProjectM36.Relation as R

98import ProjectM36.Relation.Show.Term

109import qualified ProjectM36.Relation.Show.HTML as RelHTML

@@ -31,7 +30,6 @@ data AttributeOrder = AttributeOrder AttributeName Order

3130data Order = AscendingOrder | DescendingOrder

3231 deriving (Eq, Show, Generic)

3332

34−

3533ascending :: T.Text

3634ascending = "⬆"

3735

@@ -132,7 +130,6 @@ data DataFrameExpr = DataFrameExpr {

132130 limit :: Maybe Integer

133131 }

134132 deriving (Show, Generic)

135−

136133

137134dataFrameAsHTML :: DataFrame -> T.Text

138135-- web browsers don't display tables with empty cells or empty headers, so we have to insert some placeholders- it's not technically the same, but looks as expected in the browser

src/lib/ProjectM36/DatabaseContext.hs−1

@@ -7,7 +7,6 @@ import ProjectM36.DataTypes.Basic

77import ProjectM36.AtomFunctions.Basic

88import ProjectM36.Relation

99import qualified Data.ByteString.Lazy as BL

10−import Data.Binary as B

1110import ProjectM36.AtomFunction as AF

1211import ProjectM36.DatabaseContextFunction as DBCF

1312import Codec.Winery

src/lib/ProjectM36/DatabaseContextFunction.hs+1−1

@@ -3,7 +3,7 @@ module ProjectM36.DatabaseContextFunction where

33--implements functions which operate as: [Atom] -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr

44import ProjectM36.Base

55import ProjectM36.Error

6−import ProjectM36.Serialise.Base

6+import ProjectM36.Serialise.Base ()

77import ProjectM36.Attribute as A

88import ProjectM36.Relation

99import ProjectM36.AtomType

src/lib/ProjectM36/DatabaseContextFunctionError.hs+1−2

@@ -1,9 +1,8 @@

11{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}

22module ProjectM36.DatabaseContextFunctionError where

33import GHC.Generics

4−import Data.Binary

54import Control.DeepSeq

76{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}

87data DatabaseContextFunctionError = DatabaseContextFunctionUserError String

9− deriving (Generic, Eq, Show, Binary, NFData)

8+ deriving (Generic, Eq, Show, NFData)

src/lib/ProjectM36/Error.hs+1−6

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

103103 | TupleExprsReferenceMultipleMarkersError

104104

105105 | MerkleHashValidationError TransactionId MerkleHash MerkleHash

106−

106+

107107 | MultipleErrors [RelationalError]

108108 deriving (Show,Eq,Generic,Typeable, NFData)

109109

@@ -145,8 +145,3 @@ data SchemaError = RelVarReferencesMissing (S.Set RelVarName) |

145145 RelVarOutReferencedMoreThanOnce RelVarName

146146 deriving (Show, Eq, Generic, Typeable, NFData)

147147

148−

149−-- errors returned from the distributed-process call handlers

150−data ServerError = RequestTimeoutError |

151− ProcessDiedError String

152− deriving (Generic, Eq)

src/lib/ProjectM36/IsomorphicSchema.hs−3

@@ -12,7 +12,6 @@ import GHC.Generics

1212import qualified Data.Map as M

1313import qualified Data.Set as S

1414import qualified Data.List as L

15−import Codec.Winery hiding (Schema)

1615#if __GLASGOW_HASKELL__ < 804

1716import Data.Monoid

1817#endif

@@ -29,8 +28,6 @@ import Data.Monoid

2928data SchemaExpr = AddSubschema SchemaName SchemaIsomorphs |

3029 RemoveSubschema SchemaName

3130 deriving (Generic, Show)

32− deriving Serialise via WineryVariant SchemaExpr

33−

3431

3532isomorphs :: Schema -> SchemaIsomorphs

3633isomorphs (Schema i) = i

src/lib/ProjectM36/MerkleHash.hs+2−3

@@ -1,10 +1,9 @@

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

1+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric, DerivingVia #-}

22module ProjectM36.MerkleHash where

33import Data.ByteString (ByteString)

44import GHC.Generics

5−import Data.Binary (Binary)

65import Control.DeepSeq (NFData)

87newtype MerkleHash = MerkleHash { _unMerkleHash :: ByteString }

9− deriving (Show, Eq, Binary, Generic, Monoid, Semigroup, NFData)

8+ deriving (Show, Eq, Generic, Monoid, Semigroup, NFData)

109

src/lib/ProjectM36/Persist.hs−1

@@ -36,7 +36,6 @@ import Foreign.C

3636#endif

3737

3838import System.IO (withFile, IOMode(WriteMode), Handle)

39−import qualified Data.ByteString.Lazy as BS

4039import qualified Data.ByteString as BS'

4140import qualified Data.Text.Encoding as TE

4241

src/lib/ProjectM36/Serialise/AtomFunctionError.hs−2

@@ -1,9 +1,7 @@

11{-# LANGUAGE DerivingVia, StandaloneDeriving #-}

22{-# OPTIONS_GHC -fno-warn-orphans #-}

33module ProjectM36.Serialise.AtomFunctionError where

4−import ProjectM36.Error

54import Codec.Winery

6−import ProjectM36.Serialise.Base

75import ProjectM36.AtomFunctionError

97deriving via WineryVariant AtomFunctionError instance Serialise AtomFunctionError

src/lib/ProjectM36/Serialise/DataFrame.hs+1

@@ -3,6 +3,7 @@

33module ProjectM36.Serialise.DataFrame where

44import Codec.Winery

55import ProjectM36.DataFrame

6+import ProjectM36.Serialise.Base ()

78deriving via WineryVariant AttributeOrderExpr instance Serialise AttributeOrderExpr

89deriving via WineryVariant AttributeOrder instance Serialise AttributeOrder

src/lib/ProjectM36/Serialise/DatabaseContextFunctionError.hs−2

@@ -1,9 +1,7 @@

11{-# LANGUAGE DerivingVia, StandaloneDeriving #-}

22{-# OPTIONS_GHC -fno-warn-orphans #-}

33module ProjectM36.Serialise.DatabaseContextFunctionError where

4−import ProjectM36.Error

54import Codec.Winery

6−import ProjectM36.Serialise.Base

75import ProjectM36.DatabaseContextFunctionError

97deriving via WineryVariant DatabaseContextFunctionError instance Serialise DatabaseContextFunctionError

src/lib/ProjectM36/Serialise/Error.hs+3−3

@@ -3,9 +3,9 @@

33module ProjectM36.Serialise.Error where

44import ProjectM36.Error

55import Codec.Winery

6−import ProjectM36.Serialise.Base

7−import ProjectM36.Serialise.AtomFunctionError

8−import ProjectM36.Serialise.DatabaseContextFunctionError

6+import ProjectM36.Serialise.Base ()

7+import ProjectM36.Serialise.AtomFunctionError ()

8+import ProjectM36.Serialise.DatabaseContextFunctionError ()

1010deriving via WineryVariant RelationalError instance Serialise RelationalError

1111deriving via WineryVariant MergeError instance Serialise MergeError

src/lib/ProjectM36/Serialise/IsomorphicSchema.hsnew file+7

@@ -0,0 +1,7 @@

1+{-# LANGUAGE StandaloneDeriving, DerivingVia, TypeApplications, TypeSynonymInstances, ScopedTypeVariables, GeneralizedNewtypeDeriving #-}

2+{-# OPTIONS_GHC -fno-warn-orphans #-}

3+module ProjectM36.Serialise.IsomorphicSchema where

4+import Codec.Winery

5+import ProjectM36.IsomorphicSchema

7+deriving via WineryVariant SchemaExpr instance Serialise SchemaExpr

src/lib/ProjectM36/Server.hs+58−77

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

1−{-# LANGUAGE ScopedTypeVariables #-}

1+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}

22module ProjectM36.Server where

44import ProjectM36.Client

@@ -6,68 +6,57 @@ import ProjectM36.Server.EntryPoints

66import ProjectM36.Server.RemoteCallTypes

77import ProjectM36.Server.Config (ServerConfig(..))

88import ProjectM36.FSType

9+import ProjectM36.Server.Types

910

1011import Control.Monad.IO.Class (liftIO)

1112import Control.Concurrent.MVar (putMVar, MVar)

1213import System.IO (stderr, hPutStrLn)

1314import System.FilePath (takeDirectory)

1415import System.Directory (doesDirectoryExist)

16+import Network.RPC.Curryer.Server

17+import Network.Socket

18+import qualified StmContainers.Map as StmMap

1519

1620-- the state should be a mapping of remote connection to the disconnected transaction- the graph should be the same, so discon must be removed from the stm tuple

1721--trying to refactor this for less repetition is very challenging because the return type cannot be polymorphic or the distributed-process call gets confused and drops messages

18−serverDefinition :: Bool -> Timeout -> ProcessDefinition Connection

19−serverDefinition testBool ti = defaultProcess {

20− apiHandlers = [

21− handleCall (\conn (ExecuteHeadName sessionId) -> handleExecuteHeadName ti sessionId conn),

22− handleCall (\conn (ExecuteRelationalExpr sessionId expr) -> handleExecuteRelationalExpr ti sessionId conn expr),

23− handleCall (\conn (ExecuteDataFrameExpr sessionId expr) -> handleExecuteDataFrameExpr ti sessionId conn expr),

24− handleCall (\conn (ExecuteDatabaseContextExpr sessionId expr) -> handleExecuteDatabaseContextExpr ti sessionId conn expr),

25− handleCall (\conn (ExecuteDatabaseContextIOExpr sessionId expr) -> handleExecuteDatabaseContextIOExpr ti sessionId conn expr),

26− handleCall (\conn (ExecuteGraphExpr sessionId expr) -> handleExecuteGraphExpr ti sessionId conn expr),

27− handleCall (\conn (ExecuteTransGraphRelationalExpr sessionId expr) -> handleExecuteTransGraphRelationalExpr ti sessionId conn expr),

28− handleCall (\conn (ExecuteTypeForRelationalExpr sessionId expr) -> handleExecuteTypeForRelationalExpr ti sessionId conn expr),

29− handleCall (\conn (RetrieveInclusionDependencies sessionId) -> handleRetrieveInclusionDependencies ti sessionId conn),

30− handleCall (\conn (RetrievePlanForDatabaseContextExpr sessionId dbExpr) -> handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr),

31− handleCall (\conn (RetrieveHeadTransactionId sessionId) -> handleRetrieveHeadTransactionId ti sessionId conn),

32− handleCall (\conn (RetrieveTransactionGraph sessionId) -> handleRetrieveTransactionGraph ti sessionId conn),

33− handleCall (\conn (Login procId) -> handleLogin ti conn procId),

34− handleCall (\conn (CreateSessionAtHead headn) -> handleCreateSessionAtHead ti conn headn),

35− handleCall (\conn (CreateSessionAtCommit commitId) -> handleCreateSessionAtCommit ti conn commitId),

36− handleCall (\conn (CloseSession sessionId) -> handleCloseSession ti sessionId conn),

37− handleCall (\conn (RetrieveAtomTypesAsRelation sessionId) -> handleRetrieveAtomTypesAsRelation ti sessionId conn),

38− handleCall (\conn (RetrieveRelationVariableSummary sessionId) -> handleRetrieveRelationVariableSummary ti sessionId conn),

39− handleCall (\conn (RetrieveAtomFunctionSummary sessionId) -> handleRetrieveAtomFunctionSummary ti sessionId conn),

40− handleCall (\conn (RetrieveDatabaseContextFunctionSummary sessionId) -> handleRetrieveDatabaseContextFunctionSummary ti sessionId conn),

41− handleCall (\conn (RetrieveCurrentSchemaName sessionId) -> handleRetrieveCurrentSchemaName ti sessionId conn),

42− handleCall (\conn (ExecuteSchemaExpr sessionId schemaExpr) -> handleExecuteSchemaExpr ti sessionId conn schemaExpr),

43− handleCall (\conn (RetrieveSessionIsDirty sessionId) -> handleRetrieveSessionIsDirty ti sessionId conn),

44− handleCall (\conn (ExecuteAutoMergeToHead sessionId strat headName') -> handleExecuteAutoMergeToHead ti sessionId conn strat headName'),

45− handleCall (\conn (RetrieveTypeConstructorMapping sessionId) -> handleRetrieveTypeConstructorMapping ti sessionId conn),

46− handleCall (\conn (ExecuteValidateMerkleHashes sessionId) -> handleValidateMerkleHashes ti sessionId conn),

47− handleCall (\conn Logout -> handleLogout ti conn)

48− ] ++ testModeHandlers,

49− unhandledMessagePolicy = Terminate

50− --unhandledMessagePolicy = Log

51− }

52− where

53− testModeHandlers = [handleCall (\conn (TestTimeout sessionId) -> handleTestTimeout ti sessionId conn) | testBool]

54−

55−initServer :: InitHandler (Connection, DatabaseName, Maybe (MVar EndPointAddress), EndPointAddress) Connection

56−initServer (conn, dbname, mAddressMVar, saddress) = do

57− registerDB dbname

58− case mAddressMVar of

59− Nothing -> pure ()

60− Just addressMVar -> liftIO $ putMVar addressMVar saddress

61− --traceShowM ("server started on " ++ show saddress)

62− pure $ InitOk conn Infinity

22+type TestMode = Bool

6323

64−registerDB :: DatabaseName -> Process ()

65−registerDB dbname = do

66− self <- getSelfPid

67− let dbname' = remoteDBLookupName dbname

68− register dbname' self

69− --liftIO $ putStrLn $ "registered " ++ (show self) ++ " " ++ dbname'

70−

24+requestHandlers :: TestMode -> Maybe Timeout -> RequestHandlers ServerState

25+requestHandlers testBool ti =

26+ [

27+ RequestHandler $ \conn (ExecuteHeadName sessionId) -> handleExecuteHeadName ti sessionId conn,

28+ RequestHandler (\conn (ExecuteRelationalExpr sessionId expr) -> handleExecuteRelationalExpr ti sessionId conn expr),

29+ RequestHandler (\conn (ExecuteDataFrameExpr sessionId expr) -> handleExecuteDataFrameExpr ti sessionId conn expr),

30+ RequestHandler (\conn (ExecuteDatabaseContextExpr sessionId expr) -> handleExecuteDatabaseContextExpr ti sessionId conn expr),

31+ RequestHandler (\conn (ExecuteDatabaseContextIOExpr sessionId expr) -> handleExecuteDatabaseContextIOExpr ti sessionId conn expr),

32+ RequestHandler (\conn (ExecuteGraphExpr sessionId expr) -> handleExecuteGraphExpr ti sessionId conn expr),

33+ RequestHandler (\conn (ExecuteTransGraphRelationalExpr sessionId expr) -> handleExecuteTransGraphRelationalExpr ti sessionId conn expr),

34+ RequestHandler (\conn (ExecuteTypeForRelationalExpr sessionId expr) -> handleExecuteTypeForRelationalExpr ti sessionId conn expr),

35+ RequestHandler (\conn (RetrieveInclusionDependencies sessionId) -> handleRetrieveInclusionDependencies ti sessionId conn),

36+ RequestHandler (\conn (RetrievePlanForDatabaseContextExpr sessionId dbExpr) -> handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr),

37+ RequestHandler (\conn (RetrieveHeadTransactionId sessionId) -> handleRetrieveHeadTransactionId ti sessionId conn),

38+ RequestHandler (\conn (RetrieveTransactionGraph sessionId) -> handleRetrieveTransactionGraph ti sessionId conn),

39+ RequestHandler (\conn (Login dbName) -> handleLogin dbName ti conn),

40+ RequestHandler (\conn (CreateSessionAtHead headn) -> handleCreateSessionAtHead ti conn headn),

41+ RequestHandler (\conn (CreateSessionAtCommit commitId) -> handleCreateSessionAtCommit ti conn commitId),

42+ RequestHandler (\conn (CloseSession sessionId) -> handleCloseSession ti sessionId conn),

43+ RequestHandler (\conn (RetrieveAtomTypesAsRelation sessionId) -> handleRetrieveAtomTypesAsRelation ti sessionId conn),

44+ RequestHandler (\conn (RetrieveRelationVariableSummary sessionId) -> handleRetrieveRelationVariableSummary ti sessionId conn),

45+ RequestHandler (\conn (RetrieveAtomFunctionSummary sessionId) -> handleRetrieveAtomFunctionSummary ti sessionId conn),

46+ RequestHandler (\conn (RetrieveDatabaseContextFunctionSummary sessionId) -> handleRetrieveDatabaseContextFunctionSummary ti sessionId conn),

47+ RequestHandler (\conn (RetrieveCurrentSchemaName sessionId) -> handleRetrieveCurrentSchemaName ti sessionId conn),

48+ RequestHandler (\conn (ExecuteSchemaExpr sessionId schemaExpr) -> handleExecuteSchemaExpr ti sessionId conn schemaExpr),

49+ RequestHandler (\conn (RetrieveSessionIsDirty sessionId) -> handleRetrieveSessionIsDirty ti sessionId conn),

50+ RequestHandler (\conn (ExecuteAutoMergeToHead sessionId strat headName') -> handleExecuteAutoMergeToHead ti sessionId conn strat headName'),

51+ RequestHandler (\conn (RetrieveTypeConstructorMapping sessionId) -> handleRetrieveTypeConstructorMapping ti sessionId conn),

52+ RequestHandler (\conn (ExecuteValidateMerkleHashes sessionId) -> handleValidateMerkleHashes ti sessionId conn),

53+ RequestHandler (\conn Logout -> handleLogout ti conn)

54+ ] ++ if testMode then testModeHandlers else []

55+

56+testModeHandlers :: Maybe Timeout -> RequestHandlers ServerState

57+testModeHandlers ti = [RequestHandler (\conn (TestTimeout sessionId) -> handleTestTimeout ti sessionId conn)]

58+

59+

7160-- | A notification callback which logs the notification to stderr and does nothing else.

7261loggingNotificationCallback :: NotificationCallback

7362loggingNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received \"" ++ show notName ++ "\": " ++ show evaldNot

@@ -92,9 +81,11 @@ checkFSType performCheck strat =

9281checkFSErrorMsg :: String

9382checkFSErrorMsg = "The filesystem does not support journaling so writes may not be crash-safe. Use --disable-fscheck to disable this fatal error."

9483

84+type ServerState = StmMap.Map DatabaseName InProcessConnectionConf

85+

9586-- | A synchronous function to start the project-m36 daemon given an appropriate 'ServerConfig'. Note that this function only returns if the server exits. Returns False if the daemon exited due to an error. If the second argument is not Nothing, the port is put after the server is ready to service the port.

96−launchServer :: ServerConfig -> Maybe (MVar EndPointAddress) -> IO Bool

97−launchServer daemonConfig mAddressMVar = do

87+launchServer :: ServerConfig -> Maybe (MVar SockAddr) -> IO Bool

88+launchServer daemonConfig mAddr = do

9889 checkFSResult <- checkFSType (checkFS daemonConfig) (persistenceStrategy daemonConfig)

9990 if not checkFSResult then do

10091 hPutStrLn stderr checkFSErrorMsg

@@ -108,25 +99,15 @@ launchServer daemonConfig mAddressMVar = do

10899 Right conn -> do

109100 let hostname = bindHost daemonConfig

110101 port = bindPort daemonConfig

111−#if MIN_VERSION_network_transport_tcp(0,7,0)

112− etransport <- createTransport (defaultTCPAddr hostname (show port)) defaultTCPParameters

113−#elif MIN_VERSION_network_transport_tcp(0,6,0)

114− etransport <- createTransport hostname (show port) (\nam -> (hostname, nam)) defaultTCPParameters

115−#else

116− etransport <- createTransport hostname (show port) defaultTCPParameters

117−#endif

118− case etransport of

119− Left err -> error ("failed to create transport: " ++ show err)

120− Right transport -> do

121− eEndpoint <- newEndPoint transport

122− case eEndpoint of

123− Left err -> hPutStrLn stderr ("Failed to create transport: " ++ show err) >> pure False

124− Right endpoint -> do

125− localTCPNode <- newLocalNode transport initRemoteTable

126− --traceShowM ("newLocalNode in Server " ++ show (localNodeId localTCPNode))

127− runProcess localTCPNode $ do

128− let testBool = testMode daemonConfig

129− reqTimeout = perRequestTimeout daemonConfig

130− serve (conn, databaseName daemonConfig, mAddressMVar, address endpoint) initServer (serverDefinition testBool reqTimeout)

131− liftIO $ putStrLn "serve returned"

132− pure True

102+

103+ --curryer only supports IPv4 for now

104+ let addrHints = defaultHints { addrSocketType = Stream, addrFamily = AF_INET }

105+ hostAddrs <- getAddrInfo (Just addrHints) (Just hostname) Nothing

106+ case hostAddrs of

107+ [] -> hPutStrLn stderr ("Failed to resolve: " <> hostname) >> pure False

108+ (AddrInfo _ _ _ _ (SockAddrInet _ addr32) _):_ -> do

109+ let hostAddr = hostAddressToTuple addr32

110+ initialServerState <- StmMap.newIO @DatabaseName @InProcessConnectionConf

111+ serve requestHandlers initialServerState hostAddr port mAddr

112+

113+

src/lib/ProjectM36/Server/EntryPoints.hs+104−138

@@ -3,176 +3,142 @@ module ProjectM36.Server.EntryPoints where

33import ProjectM36.Base hiding (inclusionDependencies)

44import ProjectM36.IsomorphicSchema

55import ProjectM36.Client as C

6−import ProjectM36.Error

7−import Control.Distributed.Process (Process, ProcessId)

8−import Control.Distributed.Process.ManagedProcess (ProcessReply)

9−import Control.Distributed.Process.ManagedProcess.Server (reply)

10−import Control.Distributed.Process.Async (async, task, waitCancelTimeout, AsyncResult(..))

11−import Control.Monad.IO.Class (liftIO)

126import Data.Map

137import Control.Concurrent (threadDelay)

14−import Data.Typeable

15−import Data.Binary

8+import Network.RPC.Curryer.Server

9+import System.Timeout

10+import Network.Socket

11+import Control.Exception

1612

17−timeoutOrDie :: (Binary a, Typeable a) => Timeout -> IO a -> Process (Either ServerError a)

18−timeoutOrDie micros act =

19− if micros == 0 then

20− liftIO act >>= \x -> pure (Right x)

21− else do

22− asyncUnit <- async (task (liftIO act))

23− asyncRes <- waitCancelTimeout micros asyncUnit

24− case asyncRes of

25− AsyncDone x -> pure (Right x)

26− AsyncCancelled -> pure (Left RequestTimeoutError)

27− AsyncFailed reason -> pure (Left (ProcessDiedError (show reason)))

28− AsyncLinkFailed reason -> pure (Left (ProcessDiedError (show reason)))

29− AsyncPending -> pure (Left (ProcessDiedError "process pending"))

30−

31−type Timeout = Int

32−

33−type Reply a = Process (ProcessReply (Either ServerError a) Connection)

34−

35−handleExecuteRelationalExpr :: Timeout -> SessionId -> Connection -> RelationalExpr -> Reply (Either RelationalError Relation)

36−handleExecuteRelationalExpr ti sessionId conn expr = do

37− ret <- timeoutOrDie ti (executeRelationalExpr sessionId conn expr)

38− reply ret conn

13+timeoutOrDie :: Maybe Timeout -> IO a -> IO (Maybe a)

14+timeoutOrDie mMicros act =

15+ case mMicros of

16+ Nothing -> do

17+ ret <- act

18+ pure (Just ret)

19+ Just micros -> do

20+ timeout (fromIntegral micros) act

3921

40−handleExecuteDataFrameExpr :: Timeout -> SessionId -> Connection -> DataFrameExpr -> Reply (Either RelationalError DataFrame)

41−handleExecuteDataFrameExpr ti sessionId conn expr = do

42− ret <- timeoutOrDie ti (executeDataFrameExpr sessionId conn expr)

43− reply ret conn

44−

45−handleExecuteDatabaseContextExpr :: Timeout -> SessionId -> Connection -> DatabaseContextExpr -> Reply (Either RelationalError ())

46−handleExecuteDatabaseContextExpr ti sessionId conn dbexpr = do

47− ret <- timeoutOrDie ti (executeDatabaseContextExpr sessionId conn dbexpr)

48− reply ret conn

49−

50−handleExecuteDatabaseContextIOExpr :: Timeout -> SessionId -> Connection -> DatabaseContextIOExpr -> Reply (Either RelationalError ())

51−handleExecuteDatabaseContextIOExpr ti sessionId conn dbexpr = do

52− ret <- timeoutOrDie ti (executeDatabaseContextIOExpr sessionId conn dbexpr)

53− reply ret conn

54−

55−handleExecuteHeadName :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError HeadName)

56−handleExecuteHeadName ti sessionId conn = do

57− ret <- timeoutOrDie ti (headName sessionId conn)

58− reply ret conn

59−

60−handleLogin :: Timeout -> Connection -> ProcessId -> Reply Bool

61−handleLogin ti conn newClientProcessId = do

62− ret <- timeoutOrDie ti (addClientNode conn newClientProcessId)

22+timeoutRelErr :: Maybe Timeout -> IO (Either RelationalError a) -> IO (Either RelationalError a)

23+timeoutRelErr mMicros act = do

24+ ret <- timeoutOrDie mMicros act

6325 case ret of

64− Right () -> reply (Right True) conn

65− Left err -> reply (Left err) conn

26+ Nothing -> throw TimeoutException

27+ Just v -> pure v

28+

29+

30+handleExecuteRelationalExpr :: Maybe Timeout -> SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)

31+handleExecuteRelationalExpr ti sessionId conn expr =

32+ timeoutRelErr ti (executeRelationalExpr sessionId conn expr)

33+

34+handleExecuteDataFrameExpr :: Maybe Timeout -> SessionId -> Connection -> DataFrameExpr -> IO (Either RelationalError DataFrame)

35+handleExecuteDataFrameExpr ti sessionId conn expr =

36+ timeoutRelErr ti (executeDataFrameExpr sessionId conn expr)

37+

38+handleExecuteDatabaseContextExpr :: Maybe Timeout -> SessionId -> Connection -> DatabaseContextExpr -> IO (Either RelationalError ())

39+handleExecuteDatabaseContextExpr ti sessionId conn dbexpr =

40+ timeoutRelErr ti (executeDatabaseContextExpr sessionId conn dbexpr)

41+

42+handleExecuteDatabaseContextIOExpr :: Maybe Timeout -> SessionId -> Connection -> DatabaseContextIOExpr -> IO (Either RelationalError ())

43+handleExecuteDatabaseContextIOExpr ti sessionId conn dbexpr =

44+ timeoutRelErr ti (executeDatabaseContextIOExpr sessionId conn dbexpr)

45+

46+handleExecuteHeadName :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError HeadName)

47+handleExecuteHeadName ti sessionId conn =

48+ timeoutRelErr ti (headName sessionId conn)

6649

67−handleExecuteGraphExpr :: Timeout -> SessionId -> Connection -> TransactionGraphOperator -> Reply (Either RelationalError ())

50+handleLogin :: DatabaseName -> Connection -> Locking Socket -> IO Bool

51+handleLogin dbName conn lockSock = do

52+ addClientNode dbName conn lockSock

53+ pure True

54+

55+handleExecuteGraphExpr :: Maybe Timeout -> SessionId -> Connection -> TransactionGraphOperator -> IO (Either RelationalError ())

6856handleExecuteGraphExpr ti sessionId conn graphExpr = do

69− ret <- timeoutOrDie ti (executeGraphExpr sessionId conn graphExpr)

70− reply ret conn

57+ timeoutRelErr ti (executeGraphExpr sessionId conn graphExpr)

7158

72−handleExecuteTransGraphRelationalExpr :: Timeout -> SessionId -> Connection -> TransGraphRelationalExpr -> Reply (Either RelationalError Relation)

73−handleExecuteTransGraphRelationalExpr ti sessionId conn graphExpr = do

74− ret <- timeoutOrDie ti (executeTransGraphRelationalExpr sessionId conn graphExpr)

75− reply ret conn

59+handleExecuteTransGraphRelationalExpr :: Maybe Timeout -> SessionId -> Connection -> TransGraphRelationalExpr -> IO (Either RelationalError Relation)

60+handleExecuteTransGraphRelationalExpr ti sessionId conn graphExpr =

61+ timeoutRelErr ti (executeTransGraphRelationalExpr sessionId conn graphExpr)

7662

77−handleExecuteTypeForRelationalExpr :: Timeout -> SessionId -> Connection -> RelationalExpr -> Reply (Either RelationalError Relation)

78−handleExecuteTypeForRelationalExpr ti sessionId conn relExpr = do

79− ret <- timeoutOrDie ti (typeForRelationalExpr sessionId conn relExpr)

80− reply ret conn

63+handleExecuteTypeForRelationalExpr :: Maybe Timeout -> SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)

64+handleExecuteTypeForRelationalExpr ti sessionId conn relExpr =

65+ timeoutRelErr ti (typeForRelationalExpr sessionId conn relExpr)

8166

82−handleRetrieveInclusionDependencies :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError (Map IncDepName InclusionDependency))

67+handleRetrieveInclusionDependencies :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError (Map IncDepName InclusionDependency))

8368handleRetrieveInclusionDependencies ti sessionId conn = do

84− ret <- timeoutOrDie ti (inclusionDependencies sessionId conn)

85− reply ret conn

69+ timeoutRelErr ti (inclusionDependencies sessionId conn)

8670

87−handleRetrievePlanForDatabaseContextExpr :: Timeout -> SessionId -> Connection -> DatabaseContextExpr -> Reply (Either RelationalError GraphRefDatabaseContextExpr)

71+handleRetrievePlanForDatabaseContextExpr :: Maybe Timeout -> SessionId -> Connection -> DatabaseContextExpr -> IO (Either RelationalError GraphRefDatabaseContextExpr)

8872handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr = do

89− ret <- timeoutOrDie ti (planForDatabaseContextExpr sessionId conn dbExpr)

90− reply ret conn

91−

92−handleRetrieveTransactionGraph :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)

93−handleRetrieveTransactionGraph ti sessionId conn = do

94− ret <- timeoutOrDie ti (transactionGraphAsRelation sessionId conn)

95− reply ret conn

96−

97−handleRetrieveHeadTransactionId :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError TransactionId)

98−handleRetrieveHeadTransactionId ti sessionId conn = do

99− ret <- timeoutOrDie ti (headTransactionId sessionId conn)

100− reply ret conn

101−

102−handleCreateSessionAtCommit :: Timeout -> Connection -> TransactionId -> Reply (Either RelationalError SessionId)

103−handleCreateSessionAtCommit ti conn commitId = do

104− ret <- timeoutOrDie ti (createSessionAtCommit conn commitId)

105− reply ret conn

106−

107−handleCreateSessionAtHead :: Timeout -> Connection -> HeadName -> Reply (Either RelationalError SessionId)

108−handleCreateSessionAtHead ti conn headn = do

109− ret <- timeoutOrDie ti (createSessionAtHead conn headn)

110− reply ret conn

111−

112−handleCloseSession :: Timeout -> SessionId -> Connection -> Reply ()

113−handleCloseSession ti sessionId conn = do

114− ret <- timeoutOrDie ti (closeSession sessionId conn)

115− case ret of

116− Right () -> reply (Right ()) conn

117− Left err -> reply (Left err) conn

73+ timeoutRelErr ti (planForDatabaseContextExpr sessionId conn dbExpr)

74+

75+handleRetrieveTransactionGraph :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Relation)

76+handleRetrieveTransactionGraph ti sessionId conn =

77+ timeoutRelErr ti (transactionGraphAsRelation sessionId conn)

78+

79+handleRetrieveHeadTransactionId :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError TransactionId)

80+handleRetrieveHeadTransactionId ti sessionId conn =

81+ timeoutRelErr ti (headTransactionId sessionId conn)

82+

83+handleCreateSessionAtCommit :: Maybe Timeout -> Connection -> TransactionId -> IO (Either RelationalError SessionId)

84+handleCreateSessionAtCommit ti conn commitId =

85+ timeoutRelErr ti (createSessionAtCommit conn commitId)

86+

87+handleCreateSessionAtHead :: Maybe Timeout -> Connection -> HeadName -> IO (Either RelationalError SessionId)

88+handleCreateSessionAtHead ti conn headn =

89+ timeoutRelErr ti (createSessionAtHead conn headn)

90+

91+handleCloseSession :: SessionId -> Connection -> IO ()

92+handleCloseSession sessionId conn =

93+ closeSession sessionId conn

11894

119−handleRetrieveAtomTypesAsRelation :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)

95+handleRetrieveAtomTypesAsRelation :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Relation)

12096handleRetrieveAtomTypesAsRelation ti sessionId conn = do

121− ret <- timeoutOrDie ti (atomTypesAsRelation sessionId conn)

122− reply ret conn

97+ timeoutRelErr ti (atomTypesAsRelation sessionId conn)

12398

12499-- | Returns a relation which lists the names of relvars in the current session as well as its types.

125−handleRetrieveRelationVariableSummary :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)

100+handleRetrieveRelationVariableSummary :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Relation)

126101handleRetrieveRelationVariableSummary ti sessionId conn = do

127− ret <- timeoutOrDie ti (relationVariablesAsRelation sessionId conn)

128− reply ret conn

102+ timeoutRelErr ti (relationVariablesAsRelation sessionId conn)

129103

130−handleRetrieveAtomFunctionSummary :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)

131−handleRetrieveAtomFunctionSummary ti sessionId conn = do

132− ret <- timeoutOrDie ti (atomFunctionsAsRelation sessionId conn)

133− reply ret conn

104+handleRetrieveAtomFunctionSummary :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Relation)

105+handleRetrieveAtomFunctionSummary ti sessionId conn =

106+ timeoutRelErr ti (atomFunctionsAsRelation sessionId conn)

134107

135−handleRetrieveDatabaseContextFunctionSummary :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)

136−handleRetrieveDatabaseContextFunctionSummary ti sessionId conn = do

137− ret <- timeoutOrDie ti (databaseContextFunctionsAsRelation sessionId conn)

138− reply ret conn

108+handleRetrieveDatabaseContextFunctionSummary :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Relation)

109+handleRetrieveDatabaseContextFunctionSummary ti sessionId conn =

110+ timeoutRelErr ti (databaseContextFunctionsAsRelation sessionId conn)

139111

140−handleRetrieveCurrentSchemaName :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError SchemaName)

112+handleRetrieveCurrentSchemaName :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError SchemaName)

141113handleRetrieveCurrentSchemaName ti sessionId conn = do

142− ret <- timeoutOrDie ti (currentSchemaName sessionId conn)

143− reply ret conn

114+ timeoutRelErr ti (currentSchemaName sessionId conn)

144115

145−handleExecuteSchemaExpr :: Timeout -> SessionId -> Connection -> SchemaExpr -> Reply (Either RelationalError ())

116+handleExecuteSchemaExpr :: Maybe Timeout -> SessionId -> Connection -> SchemaExpr -> IO (Either RelationalError ())

146117handleExecuteSchemaExpr ti sessionId conn schemaExpr = do

147− ret <- timeoutOrDie ti (executeSchemaExpr sessionId conn schemaExpr)

148− reply ret conn

118+ timeoutRelErr ti (executeSchemaExpr sessionId conn schemaExpr)

149119

150−handleLogout :: Timeout -> Connection -> Reply Bool

151−handleLogout _ =

120+handleLogout :: Maybe Timeout -> Connection -> IO Bool

121+handleLogout _ _ =

152122 --liftIO $ closeRemote_ conn

153− reply (pure True)

123+ pure True

154124

155−handleTestTimeout :: Timeout -> SessionId -> Connection -> Reply Bool

156−handleTestTimeout ti _ conn = do

157− ret <- timeoutOrDie ti (threadDelay 100000 >> pure True)

158− reply ret conn

125+handleTestTimeout :: Maybe Timeout -> SessionId -> Connection -> IO Bool

126+handleTestTimeout ti _ _ = do

127+ _ <- timeoutOrDie ti (threadDelay 100000 >> pure True)

128+ pure True

159129

160−handleRetrieveSessionIsDirty :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Bool)

130+handleRetrieveSessionIsDirty :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Bool)

161131handleRetrieveSessionIsDirty ti sessionId conn = do

162− ret <- timeoutOrDie ti (disconnectedTransactionIsDirty sessionId conn)

163− reply ret conn

132+ timeoutRelErr ti (disconnectedTransactionIsDirty sessionId conn)

164133

165−handleExecuteAutoMergeToHead :: Timeout -> SessionId -> Connection -> MergeStrategy -> HeadName -> Reply (Either RelationalError ())

134+handleExecuteAutoMergeToHead :: Maybe Timeout -> SessionId -> Connection -> MergeStrategy -> HeadName -> IO (Either RelationalError ())

166135handleExecuteAutoMergeToHead ti sessionId conn strat headName' = do

167− ret <- timeoutOrDie ti (autoMergeToHead sessionId conn strat headName')

168− reply ret conn

136+ timeoutRelErr ti (autoMergeToHead sessionId conn strat headName')

169137

170−handleRetrieveTypeConstructorMapping :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError TypeConstructorMapping)

138+handleRetrieveTypeConstructorMapping :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError TypeConstructorMapping)

171139handleRetrieveTypeConstructorMapping ti sessionId conn = do

172− ret <- timeoutOrDie ti (C.typeConstructorMapping sessionId conn)

173− reply ret conn

140+ timeoutRelErr ti (C.typeConstructorMapping sessionId conn)

174141

175−handleValidateMerkleHashes :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError ())

142+handleValidateMerkleHashes :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError ())

176143handleValidateMerkleHashes ti sessionId conn = do

177− ret <- timeoutOrDie ti (C.validateMerkleHashes sessionId conn)

178− reply ret conn

144+ timeoutRelErr ti (C.validateMerkleHashes sessionId conn)

src/lib/ProjectM36/Server/RemoteCallTypes.hs+93−56

@@ -1,67 +1,104 @@

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

1+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DerivingVia, DerivingStrategies, DeriveGeneric, CPP #-}

22module ProjectM36.Server.RemoteCallTypes where

33import ProjectM36.Base

4−import ProjectM36.Error

5−import ProjectM36.Serialise.Error

6−import Data.Map (Map)

74import ProjectM36.IsomorphicSchema

85import ProjectM36.TransactionGraph

96import ProjectM36.DataFrame

107import ProjectM36.TransGraphRelationalExpression

118import ProjectM36.Session

12−import ProjectM36.Serialise.DataFrame

9+import ProjectM36.Serialise.DataFrame ()

10+import ProjectM36.Serialise.IsomorphicSchema ()

11+import ProjectM36.Server.Types

1312import GHC.Generics

14−import Data.Binary

15−import Control.Distributed.Process (ProcessId)

1613import Codec.Winery

17−import Network.RPC.Curryer.Client

1814

19−data Request = Login |

20− Logout |

21− ExecuteRelationalExpr SessionId RelationalExpr |

22− ExecuteDataFrameExpr SessionId DataFrameExpr |

23− ExecuteDatabaseContextExpr SessionId DatabaseContextExpr |

24− ExecuteDatabaseContextIOExpr SessionId DatabaseContextIOExpr |

25− ExecuteGraphExpr SessionId TransactionGraphOperator |

26− ExecuteTransGraphRelationalExpr SessionId TransGraphRelationalExpr |

27− ExecuteHeadName SessionId |

28− ExecuteTypeForRelationalExpr SessionId RelationalExpr |

29− ExecuteSchemaExpr SessionId SchemaExpr |

30− ExecuteSetCurrentSchema SessionId SchemaName |

31− RetrieveInclusionDependencies SessionId |

32− RetrievePlanForDatabaseContextExpr SessionId DatabaseContextExpr |

33− RetrieveTransactionGraph SessionId |

34− RetrieveHeadTransactionId SessionId |

35− CreateSessionAtCommit TransactionId |

36− CreateSessionAtHead HeadName |

37− CloseSession SessionId |

38− RetrieveAtomTypesAsRelation SessionId |

39− RetrieveRelationVariableSummary SessionId |

40− RetrieveAtomFunctionSummary SessionId |

41− RetrieveDatabaseContextFunctionSummary SessionId |

42− RetrieveCurrentSchemaName SessionId |

43− TestTimeout SessionId |

44− RetrieveSessionIsDirty SessionId |

45− ExecuteAutoMergeToHead SessionId MergeStrategy HeadName |

46− RetrieveTypeConstructorMapping SessionId |

47− ExecuteValidateMerkleHashes SessionId

48− deriving (Generic)

49− deriving Serialise via WineryVariant Request

15+#define RPCData(typeName) deriving Generic \

16+ deriving Serialise via WineryVariant typeName

5017

51−data Response = RelationResp (Either RelationalError Relation) |

52− DataFrameResp (Either RelationalError DataFrame) |

53− EUnitResp (Either RelationalError ()) |

54− HeadNameResp (Either RelationalError HeadName) |

55− BoolResp Bool |

56− InclusionDependenciesMapResp (Map IncDepName InclusionDependency) |

57− GraphRefDatabaseContextExprResp (Either RelationalError GraphRefDatabaseContextExpr) |

58− TransactionIdResp (Either RelationalError TransactionId) |

59− SessionIdResp (Either RelationalError SessionId) |

60− UnitResp () |

61− SchemaNameResp (Either RelationalError SchemaName) |

62− EBoolResp (Either RelationalError Bool) |

63− TypeConstructorMappingResp (Either RelationalError TypeConstructorMapping)

64− deriving (Generic)

65− deriving Serialise via WineryVariant Response

66−

67−type RPCConnection = Connection Response

18+{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}

19+-- | The initial login message. The argument should be the process id of the initiating client. This ProcessId will receive notification callbacks.

20+data Login = Login DatabaseName

21+ RPCData(Login)

22+

23+data Logout = Logout

24+ RPCData(Logout)

25+

26+data ExecuteRelationalExpr = ExecuteRelationalExpr SessionId RelationalExpr

27+ RPCData(ExecuteRelationalExpr)

28+

29+data ExecuteDataFrameExpr = ExecuteDataFrameExpr SessionId DataFrameExpr

30+ RPCData(ExecuteDataFrameExpr)

31+

32+data ExecuteDatabaseContextExpr = ExecuteDatabaseContextExpr SessionId DatabaseContextExpr

33+ RPCData(ExecuteDatabaseContextExpr)

34+

35+data ExecuteDatabaseContextIOExpr = ExecuteDatabaseContextIOExpr SessionId DatabaseContextIOExpr

36+ RPCData(ExecuteDatabaseContextIOExpr)

37+

38+data ExecuteGraphExpr = ExecuteGraphExpr SessionId TransactionGraphOperator

39+ RPCData(ExecuteGraphExpr)

40+

41+data ExecuteTransGraphRelationalExpr = ExecuteTransGraphRelationalExpr SessionId TransGraphRelationalExpr

42+ RPCData(ExecuteTransGraphRelationalExpr)

43+

44+data ExecuteHeadName = ExecuteHeadName SessionId

45+ RPCData(ExecuteHeadName)

46+

47+data ExecuteTypeForRelationalExpr = ExecuteTypeForRelationalExpr SessionId RelationalExpr

48+ RPCData(ExecuteTypeForRelationalExpr)

49+

50+data ExecuteSchemaExpr = ExecuteSchemaExpr SessionId SchemaExpr RPCData(ExecuteSchemaExpr)

51+

52+data ExecuteSetCurrentSchema = ExecuteSetCurrentSchema SessionId SchemaName

53+ RPCData(ExecuteSetCurrentSchema)

54+

55+data RetrieveInclusionDependencies = RetrieveInclusionDependencies SessionId

56+ RPCData(RetrieveInclusionDependencies)

57+

58+data RetrievePlanForDatabaseContextExpr = RetrievePlanForDatabaseContextExpr SessionId DatabaseContextExpr

59+ RPCData(RetrievePlanForDatabaseContextExpr)

60+

61+data RetrieveTransactionGraph = RetrieveTransactionGraph SessionId

62+ RPCData(RetrieveTransactionGraph)

63+

64+data RetrieveHeadTransactionId = RetrieveHeadTransactionId SessionId

65+ RPCData(RetrieveHeadTransactionId)

66+

67+data CreateSessionAtCommit = CreateSessionAtCommit TransactionId

68+ RPCData(CreateSessionAtCommit)

69+

70+data CreateSessionAtHead = CreateSessionAtHead HeadName

71+ RPCData(CreateSessionAtHead)

72+

73+data CloseSession = CloseSession SessionId

74+ RPCData(CloseSession)

75+

76+data RetrieveAtomTypesAsRelation = RetrieveAtomTypesAsRelation SessionId

77+ RPCData(RetrieveAtomTypesAsRelation)

78+

79+data RetrieveRelationVariableSummary = RetrieveRelationVariableSummary SessionId

80+ RPCData(RetrieveRelationVariableSummary)

81+

82+data RetrieveAtomFunctionSummary = RetrieveAtomFunctionSummary SessionId

83+ RPCData(RetrieveAtomFunctionSummary)

84+

85+data RetrieveDatabaseContextFunctionSummary = RetrieveDatabaseContextFunctionSummary SessionId

86+ RPCData(RetrieveDatabaseContextFunctionSummary)

87+

88+data RetrieveCurrentSchemaName = RetrieveCurrentSchemaName SessionId

89+ RPCData(RetrieveCurrentSchemaName)

90+

91+data TestTimeout = TestTimeout SessionId

92+ RPCData(TestTimeout)

93+

94+data RetrieveSessionIsDirty = RetrieveSessionIsDirty SessionId

95+ RPCData(RetrieveSessionIsDirty)

96+

97+data ExecuteAutoMergeToHead = ExecuteAutoMergeToHead SessionId MergeStrategy HeadName

98+ RPCData(ExecuteAutoMergeToHead)

99+

100+data RetrieveTypeConstructorMapping = RetrieveTypeConstructorMapping SessionId

101+ RPCData(RetrieveTypeConstructorMapping)

102+

103+data ExecuteValidateMerkleHashes = ExecuteValidateMerkleHashes SessionId

104+ RPCData(ExecuteValidateMerkleHashes)

src/lib/ProjectM36/Server/Types.hsnew file+38

@@ -0,0 +1,38 @@

1+--types shared across server and client modules

2+module ProjectM36.Server.Types where

3+import StmContainers.Set as StmSet

4+import ProjectM36.Base

5+import Data.Hashable

6+import ProjectM36.Sessions

7+import Control.Concurrent.STM

8+import ProjectM36.ScriptSession

9+import ProjectM36.FileLock

10+import Control.Concurrent.MVar

11+import ProjectM36.TransactionGraph.Persist

12+import Network.RPC.Curryer.Server as RPC

13+import Network.Socket

14+

15+-- | The 'Connection' represents either local or remote access to a database. All operations flow through the connection.

16+type ClientNodes = StmSet.Set ClientInfo

17+

18+type DatabaseName = String

19+

20+-- internal structure specific to in-process connections

21+data InProcessConnectionConf = InProcessConnectionConf {

22+ ipPersistenceStrategy :: PersistenceStrategy,

23+ ipClientNodes :: ClientNodes,

24+ ipSessions :: Sessions,

25+ ipTransactionGraph :: TVar TransactionGraph,

26+ ipScriptSession :: Maybe ScriptSession,

27+ ipLocks :: Maybe (LockFile, MVar LockFileHash) -- nothing when NoPersistence

28+ }

29+

30+-- clients may connect associate one socket with one database

31+data ClientInfo = ClientInfo { databaseName :: DatabaseName,

32+ clientSocket :: RPC.Locking Socket }

33+

34+instance Eq ClientInfo where

35+ a == b = RPC.lockless (clientSocket a) == RPC.lockless (clientSocket b)

36+

37+instance Hashable ClientInfo where

38+ hashWithSalt salt ci = hashWithSalt salt (show (RPC.lockless (clientSocket ci)))