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

git.iko.soy/project-m36

on master help sign in

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

652414bAgentM6 years ago

cabal.project+2−2

compare with master

unifiedsplit

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

11source-repository-package

12 type: git

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

14− tag: 08578c17071c61ce59dbc6cb442c7ec17aeb1294

14+ tag: f67c45d1bfcb753d32ed3fe51b8e07b4c021c9bb

16source-repository-package

17 type: git

18 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

34 Default: True

36Library

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

38 if flag(haskell-scripting)

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

40 CPP-Options: -DPM36_HASKELL_SCRIPTING

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

157 MonadRandom, MonadRandom,

158 vector,

159 text,

160− vector-binary-instances,

161 time,

160 time,

162 hashable-time,

161 hashable-time,

163 bytestring,

162 bytestring,

164 stm,

163 stm,

165 deepseq,

164 deepseq,

166− binary,

167 data-interval,

165 data-interval,

168 parallel,

166 parallel,

169 cassava,

167 cassava,

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

212 Build-Depends: base,

210 Build-Depends: base,

213 ghc-paths,

211 ghc-paths,

214 project-m36,

212 project-m36,

215− binary,

216 transformers,

213 transformers,

217 temporary,

214 temporary,

218 data-interval,

215 data-interval,

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

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

1{-# LANGUAGE CPP #-}

2module ProjectM36.AtomFunction where

3import ProjectM36.Base

4−import ProjectM36.Serialise.Base

4+import ProjectM36.Serialise.Base ()

5import ProjectM36.Error

6import ProjectM36.Relation

7import ProjectM36.AtomType

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

11import qualified Data.HashSet as HS

12import qualified Data.Text as T

13import qualified Data.ByteString.Lazy as BL

14−import Data.Binary as B

15import Codec.Winery

14import Codec.Winery

17foldAtomFuncType :: AtomType -> AtomType -> [AtomType]

16foldAtomFuncType :: AtomType -> AtomType -> [AtomType]

src/lib/ProjectM36/Atomable.hs−17

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

21import qualified Data.List.NonEmpty as NE

22import Codec.Winery

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−-}

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

24-- | 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.

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

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

39 toAtom :: a -> Atom

26 toAtom :: a -> Atom

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

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

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

166 toAddTypeExpr _ = NoOperation

153 toAddTypeExpr _ = NoOperation

167

154

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

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

170−#endif

171−

172-- Generics

155-- Generics

173class AtomableG g where

156class AtomableG g where

174 --type AtomTG g

157 --type AtomTG g

src/lib/ProjectM36/Base.hs−2

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

18import qualified Data.Vector as V

19import qualified Data.List as L

20import Data.Text (Text,unpack)

21−import Data.Vector.Binary()

22import Data.Time.Clock

21import Data.Time.Clock

23import Data.Hashable.Time ()

22import Data.Hashable.Time ()

24import Data.Time.Calendar (Day)

23import Data.Time.Calendar (Day)

25import Data.Typeable

24import Data.Typeable

26import Data.ByteString (ByteString)

25import Data.ByteString (ByteString)

27import qualified Data.List.NonEmpty as NE

26import qualified Data.List.NonEmpty as NE

28−--import Codec.Winery

30type StringType = Text

28type StringType = Text

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

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

43 defaultDatabaseName,

44 defaultRemoteConnectionInfo,

45 defaultHeadName,

46+ addClientNode,

46 PersistenceStrategy(..),

47 PersistenceStrategy(..),

47 RelationalExpr,

48 RelationalExpr,

48 RelationalExprBase(..),

49 RelationalExprBase(..),

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

104 ) where

105 ) where

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

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

106import qualified ProjectM36.Base as B

107import qualified ProjectM36.Base as B

108+import ProjectM36.Serialise.Error ()

107import ProjectM36.Error

109import ProjectM36.Error

108import ProjectM36.Atomable

110import ProjectM36.Atomable

109import ProjectM36.AtomFunction as AF

111import ProjectM36.AtomFunction as AF

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

124import ProjectM36.Persist (DiskSync(..))

126import ProjectM36.Persist (DiskSync(..))

125import ProjectM36.FileLock

127import ProjectM36.FileLock

126import ProjectM36.NormalizeExpr

128import ProjectM36.NormalizeExpr

129+import ProjectM36.Server.Types

127import ProjectM36.Notifications

130import ProjectM36.Notifications

128import ProjectM36.Server.RemoteCallTypes

131import ProjectM36.Server.RemoteCallTypes

129import qualified ProjectM36.DisconnectedTransaction as Discon

132import qualified ProjectM36.DisconnectedTransaction as Discon

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

154import Control.DeepSeq (force)

157import Control.DeepSeq (force)

155import System.IO

158import System.IO

156import Data.Time.Clock

159import Data.Time.Clock

157−import Data.Typeable

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

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

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

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

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

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

161−import Data.Word

162

163

163type Hostname = String

164type Hostname = String

164

165

165type Port = Word16

166type Port = Word16

166

167

167−type DatabaseName = String

168−

169-- | 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.

168-- | 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.

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

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

171

170

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

226defaultServerHostname :: Hostname

225defaultServerHostname :: Hostname

227defaultServerHostname = "localhost"

226defaultServerHostname = "localhost"

228

227

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

228+data RemoteConnectionConf = RemoteConnectionConf RPC.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− }

245

229

246data Connection = InProcessConnection InProcessConnectionConf |

230data Connection = InProcessConnection InProcessConnectionConf |

247 RemoteConnection RemoteConnectionConf

231 RemoteConnection RemoteConnectionConf

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

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

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

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

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

293

277

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

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

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

296 --TODO- add notification callback thread

279 --TODO- add notification callback thread

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

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

298 addrSocketType = Stream

281 addrSocketType = Stream

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

303 addrInfo:_ -> do

286 addrInfo:_ -> do

304 --supports IPv4 only for now

287 --supports IPv4 only for now

305 let (SockAddrInet port addr) = addrAddress addrInfo

288 let (SockAddrInet port addr) = addrAddress addrInfo

289+-- TODO missing async callback

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

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

307 --TODO handle connection errors!

297 --TODO handle connection errors!

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

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

309 {-

299 {-

310 mServerProcessId <- whereisRemote serverNodeId dbName

300 mServerProcessId <- whereisRemote serverNodeId dbName

311 case mServerProcessId of

301 case mServerProcessId of

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

319 takeMVar connStatus

309 takeMVar connStatus

320-}

310-}

321

311

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+

322connectPersistentProjectM36 :: PersistenceStrategy ->

318connectPersistentProjectM36 :: PersistenceStrategy ->

323 DiskSync ->

319 DiskSync ->

324 FilePath ->

320 FilePath ->

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

441

437

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

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

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

439remoteCall (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+

445

446

447

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

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

src/lib/ProjectM36/DataFrame.hs−3

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

4import ProjectM36.Base

5import ProjectM36.Attribute as A

6import ProjectM36.Error

7−import ProjectM36.Serialise.Base

8import qualified ProjectM36.Relation as R

7import qualified ProjectM36.Relation as R

9import ProjectM36.Relation.Show.Term

8import ProjectM36.Relation.Show.Term

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

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

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

31data Order = AscendingOrder | DescendingOrder

30data Order = AscendingOrder | DescendingOrder

32 deriving (Eq, Show, Generic)

31 deriving (Eq, Show, Generic)

34−

35ascending :: T.Text

33ascending :: T.Text

36ascending = "⬆"

34ascending = "⬆"

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

132 limit :: Maybe Integer

130 limit :: Maybe Integer

133 }

131 }

134 deriving (Show, Generic)

132 deriving (Show, Generic)

135−

136

133

137dataFrameAsHTML :: DataFrame -> T.Text

134dataFrameAsHTML :: DataFrame -> T.Text

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

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

7import ProjectM36.AtomFunctions.Basic

8import ProjectM36.Relation

9import qualified Data.ByteString.Lazy as BL

10−import Data.Binary as B

11import ProjectM36.AtomFunction as AF

10import ProjectM36.AtomFunction as AF

12import ProjectM36.DatabaseContextFunction as DBCF

11import ProjectM36.DatabaseContextFunction as DBCF

13import Codec.Winery

12import Codec.Winery

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

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

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

4import ProjectM36.Base

5import ProjectM36.Error

6−import ProjectM36.Serialise.Base

6+import ProjectM36.Serialise.Base ()

7import ProjectM36.Attribute as A

8import ProjectM36.Relation

9import ProjectM36.AtomType

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

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

1{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}

2module ProjectM36.DatabaseContextFunctionError where

3import GHC.Generics

4−import Data.Binary

5import Control.DeepSeq

4import Control.DeepSeq

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

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

8data DatabaseContextFunctionError = DatabaseContextFunctionUserError String

7data 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)

103 | TupleExprsReferenceMultipleMarkersError

104

105 | MerkleHashValidationError TransactionId MerkleHash MerkleHash

106−

106+

107 | MultipleErrors [RelationalError]

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

109

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

145 RelVarOutReferencedMoreThanOnce RelVarName

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

147

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

12import qualified Data.Map as M

13import qualified Data.Set as S

14import qualified Data.List as L

15−import Codec.Winery hiding (Schema)

16#if __GLASGOW_HASKELL__ < 804

15#if __GLASGOW_HASKELL__ < 804

17import Data.Monoid

16import Data.Monoid

18#endif

17#endif

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

29data SchemaExpr = AddSubschema SchemaName SchemaIsomorphs |

28data SchemaExpr = AddSubschema SchemaName SchemaIsomorphs |

30 RemoveSubschema SchemaName

29 RemoveSubschema SchemaName

31 deriving (Generic, Show)

30 deriving (Generic, Show)

32− deriving Serialise via WineryVariant SchemaExpr

33−

35isomorphs :: Schema -> SchemaIsomorphs

32isomorphs :: Schema -> SchemaIsomorphs

36isomorphs (Schema i) = i

33isomorphs (Schema i) = i

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

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

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

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

2module ProjectM36.MerkleHash where

3import Data.ByteString (ByteString)

4import GHC.Generics

5−import Data.Binary (Binary)

6import Control.DeepSeq (NFData)

5import Control.DeepSeq (NFData)

8newtype MerkleHash = MerkleHash { _unMerkleHash :: ByteString }

7newtype MerkleHash = MerkleHash { _unMerkleHash :: ByteString }

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

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

src/lib/ProjectM36/Persist.hs−1

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

36#endif

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

39−import qualified Data.ByteString.Lazy as BS

40import qualified Data.ByteString as BS'

39import qualified Data.ByteString as BS'

41import qualified Data.Text.Encoding as TE

40import qualified Data.Text.Encoding as TE

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

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

1{-# LANGUAGE DerivingVia, StandaloneDeriving #-}

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

3module ProjectM36.Serialise.AtomFunctionError where

4−import ProjectM36.Error

5import Codec.Winery

4import Codec.Winery

6−import ProjectM36.Serialise.Base

7import ProjectM36.AtomFunctionError

5import ProjectM36.AtomFunctionError

9deriving via WineryVariant AtomFunctionError instance Serialise AtomFunctionError

7deriving via WineryVariant AtomFunctionError instance Serialise AtomFunctionError

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

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

3module ProjectM36.Serialise.DataFrame where

4import Codec.Winery

5import ProjectM36.DataFrame

6+import ProjectM36.Serialise.Base ()

7deriving via WineryVariant AttributeOrderExpr instance Serialise AttributeOrderExpr

8deriving via WineryVariant AttributeOrderExpr instance Serialise AttributeOrderExpr

8deriving via WineryVariant AttributeOrder instance Serialise AttributeOrder

9deriving via WineryVariant AttributeOrder instance Serialise AttributeOrder

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

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

1{-# LANGUAGE DerivingVia, StandaloneDeriving #-}

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

3module ProjectM36.Serialise.DatabaseContextFunctionError where

4−import ProjectM36.Error

5import Codec.Winery

4import Codec.Winery

6−import ProjectM36.Serialise.Base

7import ProjectM36.DatabaseContextFunctionError

5import ProjectM36.DatabaseContextFunctionError

9deriving via WineryVariant DatabaseContextFunctionError instance Serialise DatabaseContextFunctionError

7deriving via WineryVariant DatabaseContextFunctionError instance Serialise DatabaseContextFunctionError

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

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

3module ProjectM36.Serialise.Error where

4import ProjectM36.Error

5import Codec.Winery

6−import ProjectM36.Serialise.Base

6+import ProjectM36.Serialise.Base ()

7−import ProjectM36.Serialise.AtomFunctionError

7+import ProjectM36.Serialise.AtomFunctionError ()

8−import ProjectM36.Serialise.DatabaseContextFunctionError

8+import ProjectM36.Serialise.DatabaseContextFunctionError ()

10deriving via WineryVariant RelationalError instance Serialise RelationalError

11deriving 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 #-}

2module ProjectM36.Server where

4import ProjectM36.Client

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

6import ProjectM36.Server.RemoteCallTypes

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

8import ProjectM36.FSType

9+import ProjectM36.Server.Types

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

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

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

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

12import System.IO (stderr, hPutStrLn)

13import System.IO (stderr, hPutStrLn)

13import System.FilePath (takeDirectory)

14import System.FilePath (takeDirectory)

14import System.Directory (doesDirectoryExist)

15import System.Directory (doesDirectoryExist)

16+import Network.RPC.Curryer.Server

17+import Network.Socket

18+import qualified StmContainers.Map as StmMap

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

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

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

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

22+type TestMode = Bool

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

64−registerDB :: DatabaseName -> Process ()

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

65−registerDB dbname = do

25+requestHandlers testBool ti =

66− self <- getSelfPid

26+ [

67− let dbname' = remoteDBLookupName dbname

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

68− register dbname' self

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

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

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

70−

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+

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

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

72loggingNotificationCallback :: NotificationCallback

61loggingNotificationCallback :: NotificationCallback

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

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

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

92checkFSErrorMsg :: String

81checkFSErrorMsg :: String

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

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

84+type ServerState = StmMap.Map DatabaseName InProcessConnectionConf

85+

95-- | 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.

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

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

97−launchServer daemonConfig mAddressMVar = do

88+launchServer daemonConfig mAddr = do

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

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

99 if not checkFSResult then do

90 if not checkFSResult then do

100 hPutStrLn stderr checkFSErrorMsg

91 hPutStrLn stderr checkFSErrorMsg

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

108 Right conn -> do

99 Right conn -> do

109 let hostname = bindHost daemonConfig

100 let hostname = bindHost daemonConfig

110 port = bindPort daemonConfig

101 port = bindPort daemonConfig

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

102+

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

103+ --curryer only supports IPv4 for now

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

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

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

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

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

106+ case hostAddrs of

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

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

124− Right endpoint -> do

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

125− localTCPNode <- newLocalNode transport initRemoteTable

109+ let hostAddr = hostAddressToTuple addr32

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

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

127− runProcess localTCPNode $ do

111+ serve requestHandlers initialServerState hostAddr port mAddr

128− let testBool = testMode daemonConfig

112+

129− reqTimeout = perRequestTimeout daemonConfig

113+

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

131− liftIO $ putStrLn "serve returned"

132− pure True

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

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

3import ProjectM36.Base hiding (inclusionDependencies)

4import ProjectM36.IsomorphicSchema

5import 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)

12import Data.Map

6import Data.Map

13import Control.Concurrent (threadDelay)

7import Control.Concurrent (threadDelay)

14−import Data.Typeable

8+import Network.RPC.Curryer.Server

15−import Data.Binary

9+import System.Timeout

10+import Network.Socket

11+import Control.Exception

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

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

18−timeoutOrDie micros act =

14+timeoutOrDie mMicros 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

15+ case mMicros of

25− AsyncDone x -> pure (Right x)

16+ Nothing -> do

26− AsyncCancelled -> pure (Left RequestTimeoutError)

17+ ret <- act

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

18+ pure (Just ret)

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

19+ Just micros -> do

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

20+ timeout (fromIntegral micros) act

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

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

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

41−handleExecuteDataFrameExpr ti sessionId conn expr = do

23+timeoutRelErr mMicros act = do

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

24+ ret <- timeoutOrDie mMicros act

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)

63 case ret of

25 case ret of

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

26+ Nothing -> throw TimeoutException

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

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)

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

51+handleLogin dbName conn lockSock = do

52+ addClientNode dbName conn lockSock

53+ pure True

54+

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

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

68handleExecuteGraphExpr ti sessionId conn graphExpr = do

56handleExecuteGraphExpr ti sessionId conn graphExpr = do

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

57+ timeoutRelErr ti (executeGraphExpr sessionId conn graphExpr)

70− reply ret conn

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

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

73−handleExecuteTransGraphRelationalExpr ti sessionId conn graphExpr = do

60+handleExecuteTransGraphRelationalExpr ti sessionId conn graphExpr =

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

61+ timeoutRelErr ti (executeTransGraphRelationalExpr sessionId conn graphExpr)

75− reply ret conn

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

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

78−handleExecuteTypeForRelationalExpr ti sessionId conn relExpr = do

64+handleExecuteTypeForRelationalExpr ti sessionId conn relExpr =

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

65+ timeoutRelErr ti (typeForRelationalExpr sessionId conn relExpr)

80− reply ret conn

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

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

83handleRetrieveInclusionDependencies ti sessionId conn = do

68handleRetrieveInclusionDependencies ti sessionId conn = do

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

69+ timeoutRelErr ti (inclusionDependencies sessionId conn)

85− reply ret conn

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

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

88handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr = do

72handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr = do

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

73+ timeoutRelErr ti (planForDatabaseContextExpr sessionId conn dbExpr)

90− reply ret conn

74+

91−

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

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

93−handleRetrieveTransactionGraph ti sessionId conn = do

76+handleRetrieveTransactionGraph ti sessionId conn =

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

77+ timeoutRelErr ti (transactionGraphAsRelation sessionId conn)

95− reply ret conn

78+

96−

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

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

98−handleRetrieveHeadTransactionId ti sessionId conn = do

80+handleRetrieveHeadTransactionId ti sessionId conn =

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

81+ timeoutRelErr ti (headTransactionId sessionId conn)

100− reply ret conn

82+

101−

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

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

103−handleCreateSessionAtCommit ti conn commitId = do

84+handleCreateSessionAtCommit ti conn commitId =

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

85+ timeoutRelErr ti (createSessionAtCommit conn commitId)

105− reply ret conn

86+

106−

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

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

108−handleCreateSessionAtHead ti conn headn = do

88+handleCreateSessionAtHead ti conn headn =

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

89+ timeoutRelErr ti (createSessionAtHead conn headn)

110− reply ret conn

90+

111−

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

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

113−handleCloseSession ti sessionId conn = do

92+handleCloseSession sessionId conn =

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

93+ closeSession sessionId conn

115− case ret of

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

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

118

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

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

120handleRetrieveAtomTypesAsRelation ti sessionId conn = do

96handleRetrieveAtomTypesAsRelation ti sessionId conn = do

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

97+ timeoutRelErr ti (atomTypesAsRelation sessionId conn)

122− reply ret conn

123

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

99-- | 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)

126handleRetrieveRelationVariableSummary ti sessionId conn = do

101handleRetrieveRelationVariableSummary ti sessionId conn = do

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

102+ timeoutRelErr ti (relationVariablesAsRelation sessionId conn)

128− reply ret conn

129

103

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

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

131−handleRetrieveAtomFunctionSummary ti sessionId conn = do

105+handleRetrieveAtomFunctionSummary ti sessionId conn =

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

106+ timeoutRelErr ti (atomFunctionsAsRelation sessionId conn)

133− reply ret conn

134

107

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

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

136−handleRetrieveDatabaseContextFunctionSummary ti sessionId conn = do

109+handleRetrieveDatabaseContextFunctionSummary ti sessionId conn =

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

110+ timeoutRelErr ti (databaseContextFunctionsAsRelation sessionId conn)

138− reply ret conn

139

111

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

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

141handleRetrieveCurrentSchemaName ti sessionId conn = do

113handleRetrieveCurrentSchemaName ti sessionId conn = do

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

114+ timeoutRelErr ti (currentSchemaName sessionId conn)

143− reply ret conn

144

115

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

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

146handleExecuteSchemaExpr ti sessionId conn schemaExpr = do

117handleExecuteSchemaExpr ti sessionId conn schemaExpr = do

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

118+ timeoutRelErr ti (executeSchemaExpr sessionId conn schemaExpr)

148− reply ret conn

149

119

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

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

151−handleLogout _ =

121+handleLogout _ _ =

152 --liftIO $ closeRemote_ conn

122 --liftIO $ closeRemote_ conn

153− reply (pure True)

123+ pure True

154

124

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

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

156−handleTestTimeout ti _ conn = do

126+handleTestTimeout ti _ _ = do

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

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

158− reply ret conn

128+ pure True

159

129

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

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

161handleRetrieveSessionIsDirty ti sessionId conn = do

131handleRetrieveSessionIsDirty ti sessionId conn = do

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

132+ timeoutRelErr ti (disconnectedTransactionIsDirty sessionId conn)

163− reply ret conn

164

133

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

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

166handleExecuteAutoMergeToHead ti sessionId conn strat headName' = do

135handleExecuteAutoMergeToHead ti sessionId conn strat headName' = do

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

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

168− reply ret conn

169

137

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

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

171handleRetrieveTypeConstructorMapping ti sessionId conn = do

139handleRetrieveTypeConstructorMapping ti sessionId conn = do

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

140+ timeoutRelErr ti (C.typeConstructorMapping sessionId conn)

173− reply ret conn

174

141

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

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

176handleValidateMerkleHashes ti sessionId conn = do

143handleValidateMerkleHashes ti sessionId conn = do

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

144+ timeoutRelErr ti (C.validateMerkleHashes sessionId conn)

178− reply ret 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 #-}

2module ProjectM36.Server.RemoteCallTypes where

3import ProjectM36.Base

4−import ProjectM36.Error

5−import ProjectM36.Serialise.Error

6−import Data.Map (Map)

7import ProjectM36.IsomorphicSchema

4import ProjectM36.IsomorphicSchema

8import ProjectM36.TransactionGraph

5import ProjectM36.TransactionGraph

9import ProjectM36.DataFrame

6import ProjectM36.DataFrame

10import ProjectM36.TransGraphRelationalExpression

7import ProjectM36.TransGraphRelationalExpression

11import ProjectM36.Session

8import ProjectM36.Session

12−import ProjectM36.Serialise.DataFrame

9+import ProjectM36.Serialise.DataFrame ()

10+import ProjectM36.Serialise.IsomorphicSchema ()

11+import ProjectM36.Server.Types

13import GHC.Generics

12import GHC.Generics

14−import Data.Binary

15−import Control.Distributed.Process (ProcessId)

16import Codec.Winery

13import Codec.Winery

17−import Network.RPC.Curryer.Client

19−data Request = Login |

15+#define RPCData(typeName) deriving Generic \

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

16+ deriving Serialise via WineryVariant typeName

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

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

52− DataFrameResp (Either RelationalError DataFrame) |

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

53− EUnitResp (Either RelationalError ()) |

20+data Login = Login DatabaseName

54− HeadNameResp (Either RelationalError HeadName) |

21+ RPCData(Login)

55− BoolResp Bool |

22+

56− InclusionDependenciesMapResp (Map IncDepName InclusionDependency) |

23+data Logout = Logout

57− GraphRefDatabaseContextExprResp (Either RelationalError GraphRefDatabaseContextExpr) |

24+ RPCData(Logout)

58− TransactionIdResp (Either RelationalError TransactionId) |

25+

59− SessionIdResp (Either RelationalError SessionId) |

26+data ExecuteRelationalExpr = ExecuteRelationalExpr SessionId RelationalExpr

60− UnitResp () |

27+ RPCData(ExecuteRelationalExpr)

61− SchemaNameResp (Either RelationalError SchemaName) |

28+

62− EBoolResp (Either RelationalError Bool) |

29+data ExecuteDataFrameExpr = ExecuteDataFrameExpr SessionId DataFrameExpr

63− TypeConstructorMappingResp (Either RelationalError TypeConstructorMapping)

30+ RPCData(ExecuteDataFrameExpr)

64− deriving (Generic)

31+

65− deriving Serialise via WineryVariant Response

32+data ExecuteDatabaseContextExpr = ExecuteDatabaseContextExpr SessionId DatabaseContextExpr

66−

33+ RPCData(ExecuteDatabaseContextExpr)

67−type RPCConnection = Connection Response

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