diff --git a/Changelog.markdown b/Changelog.markdown --- a/Changelog.markdown +++ b/Changelog.markdown @@ -1,3 +1,9 @@ +# 2025-03-30 (v1.1.1) + +* upgrade to curryer-rpc 0.4.0 which includes support for IPv6 and Unix domain socket communications + +This improvement changes the connectProjectM36 API. When connecting to a database over IPv4 or IPv6, use `RemoteConnectionInfo (RemoteServerHostAddress ) `. + # 2024-08-25 (v1.1.0) * add support for GHC 9.6, GHC 9.8, and GHC 9.10 diff --git a/examples/Plantfarm.hs b/examples/Plantfarm.hs --- a/examples/Plantfarm.hs +++ b/examples/Plantfarm.hs @@ -2,12 +2,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingVia #-} --- The calls to 'S.raise' from the @scotty@ package are /deprecated/ --- TODO: --- Replace 'raise' with 'throw' --- --- Until then, supproess the deprecation warning -{-# OPTIONS_GHC -fno-warn-deprecations #-} module Main ( main -- * Other example exports @@ -17,14 +11,15 @@ , updatePlant ) where + +import Control.Monad.Catch (Exception) import Codec.Winery (Serialise, WineryVariant(WineryVariant)) import Control.DeepSeq (NFData) import Data.Aeson (FromJSON, ToJSON(toEncoding, toJSON)) import Data.Data (Proxy(Proxy)) import Data.Either (lefts, rights) import Data.Functor (($>)) -import Data.Text as T (Text) -import qualified Data.Text.Lazy as TL (pack) +import Data.Text as T (Text,pack) import GHC.Generics (Generic) import qualified ProjectM36.Base as Base import ProjectM36.DatabaseContext @@ -207,7 +202,7 @@ -- deleting all plants at a specific stage S.delete "/plants" $ do - s <- S.pathParam "name" + s <- S.queryParam "name" e <- liftIO $ deletePlantByName c s p <- handleWebError e S.json p @@ -218,15 +213,20 @@ ps <- handleWebErrors e S.json ps +data WebError = WebError T.Text + deriving Show + +instance Exception WebError + handleWebError :: Either Err b -> S.ActionM b -handleWebError (Left e) = S.raise . TL.pack $ "An error occurred:\n" <> show e +handleWebError (Left e) = S.throw (WebError (T.pack $ "An error occurred:\n" <> show e)) handleWebError (Right v) = pure v handleWebErrors :: [Either Err b] -> S.ActionM [b] handleWebErrors e = do case lefts e of [] -> pure (rights e) - l -> S.raise . TL.pack $ "Errors occurred:\n" <> concatMap ((<> "\n") . show) l + l -> S.throw (WebError (T.pack $ "Errors occurred:\n" <> concatMap ((<>"\n") . show) l)) -- | watering a plant and thereby possibly updating its stage diff --git a/examples/SimpleClient.hs b/examples/SimpleClient.hs --- a/examples/SimpleClient.hs +++ b/examples/SimpleClient.hs @@ -9,7 +9,7 @@ main :: IO () main = do -- 1. create a ConnectionInfo - let connInfo = RemoteConnectionInfo "mytestdb" "127.0.0.1" (show defaultServerPort) emptyNotificationCallback + let connInfo = RemoteConnectionInfo "mytestdb" defaultRemoteServerAddress emptyNotificationCallback -- 2. connected to the remote database eConn <- connectProjectM36 connInfo case eConn of diff --git a/project-m36.cabal b/project-m36.cabal --- a/project-m36.cabal +++ b/project-m36.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: project-m36 -Version: 1.1.0 +Version: 1.1.1 License: MIT --note that this license specification is erroneous and only labeled MIT to appease hackage which does not recognize public domain packages in cabal >2.2- Project:M36 is dedicated to the public domain Build-Type: Simple @@ -89,7 +89,7 @@ cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, - curryer-rpc>=0.3.7, + curryer-rpc>=0.4.0, network, async, vector-instances, @@ -271,7 +271,9 @@ http-conduit, modern-uri, http-types, - recursion-schemes + recursion-schemes, + data-default < 0.8 + --data-default 0.8.0.0 breaks http-tls-client Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, @@ -595,7 +597,7 @@ Executable Example-Plantfarm Default-Language: Haskell2010 Default-Extensions: OverloadedStrings - Build-Depends: aeson, barbies, base, containers, deepseq, hashable, project-m36, random, scotty >= 0.22, text, winery + Build-Depends: aeson, barbies, base, containers, deepseq, hashable, project-m36, random, scotty >= 0.22, text, winery, exceptions Main-Is: examples/Plantfarm.hs GHC-Options: -Wall -threaded diff --git a/src/bin/ProjectM36/Cli.hs b/src/bin/ProjectM36/Cli.hs --- a/src/bin/ProjectM36/Cli.hs +++ b/src/bin/ProjectM36/Cli.hs @@ -4,6 +4,7 @@ import qualified ProjectM36.Client as C import qualified Data.Text as T import ProjectM36.Base +import ProjectM36.Client (RemoteServerAddress(..)) import System.Console.Haskeline import Control.Exception import System.IO @@ -28,7 +29,7 @@ type ParserError = ParseErrorBundle T.Text Void data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName (Maybe DirectExecute) [GhcPkgPath] CheckFS | - RemoteInterpreterConfig C.Hostname C.Port C.DatabaseName HeadName (Maybe TutorialDExec) CheckFS + RemoteInterpreterConfig RemoteServerAddress C.DatabaseName HeadName (Maybe TutorialDExec) CheckFS outputNotificationCallback :: C.NotificationCallback outputNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received " ++ show notName ++ ":\n" ++ "\n" ++ prettyEvaluatedNotification evaldNot @@ -63,7 +64,7 @@ parseArgs :: Parser InterpreterConfig parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <*> parseDirectExecute <*> many parseGhcPkgPath <*> parseCheckFS <|> - RemoteInterpreterConfig <$> parseHostname "127.0.0.1" <*> parsePort C.defaultServerPort <*> parseDatabaseName <*> parseHeadName <*> parseDirectExecute <*> parseCheckFS + RemoteInterpreterConfig <$> parseServerAddress <*> parseDatabaseName <*> parseHeadName <*> parseDirectExecute <*> parseCheckFS parseHeadName :: Parser HeadName parseHeadName = option auto (long "head" <> @@ -120,19 +121,19 @@ connectionInfoForConfig :: InterpreterConfig -> DatabaseContext -> C.ConnectionInfo connectionInfoForConfig (LocalInterpreterConfig pStrategy _ _ ghcPkgPaths _) defaultDBContext = C.InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths defaultDBContext -connectionInfoForConfig (RemoteInterpreterConfig remoteHost remotePort remoteDBName _ _ _) _ = C.RemoteConnectionInfo remoteDBName remoteHost (show remotePort) outputNotificationCallback +connectionInfoForConfig (RemoteInterpreterConfig remoteAddress remoteDBName _ _ _) _ = C.RemoteConnectionInfo remoteDBName remoteAddress outputNotificationCallback headNameForConfig :: InterpreterConfig -> HeadName headNameForConfig (LocalInterpreterConfig _ headn _ _ _) = headn -headNameForConfig (RemoteInterpreterConfig _ _ _ headn _ _) = headn +headNameForConfig (RemoteInterpreterConfig _ _ headn _ _) = headn directExecForConfig :: InterpreterConfig -> Maybe String directExecForConfig (LocalInterpreterConfig _ _ t _ _) = t -directExecForConfig (RemoteInterpreterConfig _ _ _ _ t _) = t +directExecForConfig (RemoteInterpreterConfig _ _ _ t _) = t checkFSForConfig :: InterpreterConfig -> Bool checkFSForConfig (LocalInterpreterConfig _ _ _ _ c) = c -checkFSForConfig (RemoteInterpreterConfig _ _ _ _ _ c) = c +checkFSForConfig (RemoteInterpreterConfig _ _ _ _ c) = c persistenceStrategyForConfig :: InterpreterConfig -> Maybe PersistenceStrategy persistenceStrategyForConfig (LocalInterpreterConfig strat _ _ _ _) = Just strat diff --git a/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs b/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs --- a/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs +++ b/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs @@ -181,6 +181,9 @@ instance ToJSON RelationalError instance FromJSON RelationalError +instance ToJSON NotificationExpression +instance FromJSON NotificationExpression + instance ToJSON SQLError instance FromJSON SQLError diff --git a/src/bin/ProjectM36/Server/WebSocket.hs b/src/bin/ProjectM36/Server/WebSocket.hs --- a/src/bin/ProjectM36/Server/WebSocket.hs +++ b/src/bin/ProjectM36/Server/WebSocket.hs @@ -92,7 +92,7 @@ --this creates a new database for each connection- perhaps not what we want (?) createConnection :: WS.Connection -> DatabaseName -> Port -> Hostname -> IO (Either ConnectionError Connection) -createConnection wsconn dbname port host = connectProjectM36 (RemoteConnectionInfo dbname host (show port) (notificationCallback wsconn)) +createConnection wsconn dbname port host = connectProjectM36 (RemoteConnectionInfo dbname (RemoteServerHostAddress host port) (notificationCallback wsconn)) handleResponse :: WS.Connection -> Connection -> Response -> IO () handleResponse conn dbconn resp = diff --git a/src/bin/ProjectM36/Server/WebSocket/websocket-server.hs b/src/bin/ProjectM36/Server/WebSocket/websocket-server.hs --- a/src/bin/ProjectM36/Server/WebSocket/websocket-server.hs +++ b/src/bin/ProjectM36/Server/WebSocket/websocket-server.hs @@ -16,19 +16,22 @@ import ProjectM36.Server.Config import ProjectM36.Server.ParseArgs import ProjectM36.Server.WebSocket +import ProjectM36.Client (RemoteServerAddress(..)) main :: IO () main = do -- launch normal project-m36-server addressMVar <- newEmptyMVar - wsConfig <- parseWSConfigWithDefaults (defaultServerConfig {bindPort = 8000, bindHost = "127.0.0.1"}) + wsConfig <- parseWSConfigWithDefaults (defaultServerConfig {bindAddress = RemoteServerHostAddress "127.0.0.1" 8000}) --usurp the serverConfig for our websocket server and make the proxied server run locally let serverConfig = wsServerConfig wsConfig - wsHost = bindHost serverConfig - wsPort = bindPort serverConfig + wsAddress = bindAddress serverConfig + (wsHost, wsPort) = case wsAddress of + RemoteServerHostAddress host port -> (host, port) + _ -> error "expected host-based address" serverHost = "127.0.0.1" - serverConfig' = serverConfig {bindPort = 0, bindHost = serverHost} + serverConfig' = serverConfig {bindAddress = RemoteServerHostAddress serverHost 0} configCertificateFile = tlsCertificatePath wsConfig configKeyFile = tlsKeyPath wsConfig diff --git a/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs b/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs --- a/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs +++ b/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs @@ -31,6 +31,7 @@ ShowRelationVariables :: RODatabaseContextOperator ShowAtomFunctions :: RODatabaseContextOperator ShowDatabaseContextFunctions :: RODatabaseContextOperator + ShowNotifications :: RODatabaseContextOperator ShowDataFrame :: DF.DataFrameExpr -> RODatabaseContextOperator GetDDLHash :: RODatabaseContextOperator ShowDDL :: RODatabaseContextOperator @@ -65,6 +66,9 @@ showDatabaseContextFunctionsP :: Parser RODatabaseContextOperator showDatabaseContextFunctionsP = colonOp ":showdatabasecontextfunctions" >> pure ShowDatabaseContextFunctions +showNotificationsP :: Parser RODatabaseContextOperator +showNotificationsP = colonOp ":shownotifications" >> pure ShowNotifications + quitP :: Parser RODatabaseContextOperator quitP = do colonOp ":quit" @@ -90,6 +94,7 @@ <|> showTypesP <|> showAtomFunctionsP <|> showDatabaseContextFunctionsP + <|> showNotificationsP <|> showDataFrameP <|> ddlHashP <|> showDDLP @@ -158,6 +163,12 @@ evalRODatabaseContextOp sessionId conn ShowDatabaseContextFunctions = do eRel <- C.databaseContextFunctionsAsRelation sessionId conn + case eRel of + Left err -> pure $ DisplayErrorResult (T.pack (show err)) + Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel)) + +evalRODatabaseContextOp sessionId conn ShowNotifications = do + eRel <- C.notificationsAsRelation sessionId conn case eRel of Left err -> pure $ DisplayErrorResult (T.pack (show err)) Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel)) diff --git a/src/bin/TutorialD/Interpreter/RelationalExpr.hs b/src/bin/TutorialD/Interpreter/RelationalExpr.hs --- a/src/bin/TutorialD/Interpreter/RelationalExpr.hs +++ b/src/bin/TutorialD/Interpreter/RelationalExpr.hs @@ -158,7 +158,7 @@ relTerm :: RelationalMarkerExpr a => Parser (RelationalExprBase a) relTerm = parens relExprP <|> makeRelationP - <|> (relVarP <* notFollowedBy "(") + <|> relVarP <|> relationValuedAttributeP relationValuedAttributeP :: RelationalMarkerExpr a => Parser (RelationalExprBase a) diff --git a/src/bin/TutorialD/Interpreter/Types.hs b/src/bin/TutorialD/Interpreter/Types.hs --- a/src/bin/TutorialD/Interpreter/Types.hs +++ b/src/bin/TutorialD/Interpreter/Types.hs @@ -78,6 +78,6 @@ monoTypeConstructorP = ADTypeConstructor <$> typeConstructorNameP <*> pure [] <|> TypeVariable <$> typeVariableIdentifierP - +-- regular, uncapitalized name, but don't conflate it with a function (followed by parenthesis) relVarNameP :: Parser RelVarName -relVarNameP = uncapitalizedOrQuotedIdentifier <* spaceConsumer +relVarNameP = uncapitalizedOrQuotedIdentifier <* notFollowedBy "(" <* spaceConsumer diff --git a/src/lib/ProjectM36/AtomType.hs b/src/lib/ProjectM36/AtomType.hs --- a/src/lib/ProjectM36/AtomType.hs +++ b/src/lib/ProjectM36/AtomType.hs @@ -81,7 +81,7 @@ --if any two maps have the same key and different values, this indicates a type arg mismatch let typeVarMapFolder valMap acc = case acc of Left err -> Left err - Right accMap -> + Right accMap -> do case resolveAtomTypesInTypeVarMap valMap accMap of Left (TypeConstructorTypeVarMissing _) -> Left (DataConstructorTypeVarsMismatch (DCD.name dCons) accMap valMap) Left err -> Left err @@ -232,7 +232,7 @@ --given two atom types, try to resolve type variables resolveAtomType :: AtomType -> AtomType -> Either RelationalError AtomType -resolveAtomType (ConstructedAtomType tConsName resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) = +resolveAtomType (ConstructedAtomType tConsName resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) = do ConstructedAtomType tConsName <$> resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresolvedType then Right typeFromRelation @@ -267,10 +267,13 @@ resSubType <- resolveAtomType resType subType pure (resKey, resSubType) TypeVariableType _ -> pure (resKey, resType) - typ -> if typ == resType then - pure (resKey, resType) + -- in the data type F (Maybe Integer) (Maybe Integer), if the first Maybe Integer is "Nothing", then we want to prefer the concrete "unresolved type"- improvement: create different Haskell types for unresolved and concrete types using Void phantom type for TypeVariableType for concrete type + typ -> if isResolvedType typ then + pure (resKey, typ) + else if isResolvedType resType && typ == resType then + pure (resKey, resType) else - Left $ AtomTypeMismatchError typ resType + Left $ AtomTypeMismatchError typ resType Nothing -> pure (resKey, resType) --swipe the missing type var from the expected map tVarList <- mapM (uncurry resolveTypePair) (M.toList resolvedTypeMap) diff --git a/src/lib/ProjectM36/Base.hs b/src/lib/ProjectM36/Base.hs --- a/src/lib/ProjectM36/Base.hs +++ b/src/lib/ProjectM36/Base.hs @@ -289,6 +289,11 @@ } deriving (Show, Eq, Generic, NFData) +data NotificationExpression = NotificationChangeExpression | + NotificationReportOldExpression | + NotificationReportNewExpression + deriving (Show, Eq, Generic, NFData) + type TypeVarName = StringType -- | Metadata definition for type constructors such as @data Either a b@. diff --git a/src/lib/ProjectM36/Client.hs b/src/lib/ProjectM36/Client.hs --- a/src/lib/ProjectM36/Client.hs +++ b/src/lib/ProjectM36/Client.hs @@ -36,6 +36,7 @@ transactionGraphAsRelation, relationVariablesAsRelation, registeredQueriesAsRelation, + notificationsAsRelation, ddlAsRelation, ProjectM36.Client.atomFunctionsAsRelation, disconnectedTransactionIsDirty, @@ -108,7 +109,11 @@ AtomExprBase(..), RestrictionPredicateExprBase(..), withTransaction, - basicDatabaseContext + basicDatabaseContext, + RemoteServerAddress(..), + resolveRemoteServerAddress, + defaultRemoteServerAddress, + defaultServerHostname ) where import ProjectM36.Base hiding (inclusionDependencies) --defined in this module as well import qualified ProjectM36.Base as B @@ -172,16 +177,20 @@ import Data.Time.Clock import qualified Network.RPC.Curryer.Client as RPC import qualified Network.RPC.Curryer.Server as RPC -import Network.Socket (Socket, AddrInfo(..), getAddrInfo, defaultHints, AddrInfoFlag(..), SocketType(..), ServiceName, hostAddressToTuple, SockAddr(..)) +import Network.Socket (Socket, AddrInfo(..), getAddrInfo, defaultHints, SocketType(..), ServiceName, SockAddr, Family(..), SockAddr(..)) import GHC.Conc (unsafeIOToSTM) import ProjectM36.SQL.Select as SQL import ProjectM36.SQL.DBUpdate as SQL -import ProjectM36.SQL.Convert +import ProjectM36.SQL.Convert +import Streamly.Internal.Network.Socket (SockSpec(..)) type Hostname = String - type Port = Word16 +data RemoteServerAddress = RemoteServerHostAddress Hostname Port | + RemoteServerUnixDomainSocketAddress FilePath + deriving (Show) + -- | 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. type NotificationCallback = NotificationName -> EvaluatedNotification -> IO () @@ -203,7 +212,7 @@ -- | Construct a 'ConnectionInfo' to describe how to make the 'Connection'. The database can be run within the current process or running remotely via RPC. data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy NotificationCallback [GhcPkgPath] DatabaseContext | - RemoteConnectionInfo DatabaseName Hostname ServiceName NotificationCallback + RemoteConnectionInfo DatabaseName RemoteServerAddress NotificationCallback type EvaluatedNotifications = M.Map NotificationName EvaluatedNotification @@ -234,10 +243,14 @@ defaultHeadName :: HeadName defaultHeadName = "master" +-- | Use this for connecting to the default remote server. +defaultRemoteServerAddress :: RemoteServerAddress +defaultRemoteServerAddress = RemoteServerHostAddress "127.0.0.1" defaultServerPort + -- | Create a connection configuration which connects to the localhost on the default server port and default server database name. The configured notification callback is set to ignore all events. defaultRemoteConnectionInfo :: ConnectionInfo defaultRemoteConnectionInfo = - RemoteConnectionInfo defaultDatabaseName defaultServerHostname (show defaultServerPort) emptyNotificationCallback + RemoteConnectionInfo defaultDatabaseName defaultRemoteServerAddress emptyNotificationCallback defaultServerHostname :: Hostname defaultServerHostname = "localhost" @@ -265,6 +278,26 @@ Left err -> hPutStrLn stderr ("Warning: Haskell scripting disabled: " ++ show err) >> pure Nothing --not a fatal error, but the scripting feature must be disabled Right s -> pure (Just s) +-- | Resolve a server address using DNS, if necessary. The caller is expected to set any necessary socket options afterwards. +resolveRemoteServerAddress :: RemoteServerAddress -> IO (SockSpec, SockAddr) +resolveRemoteServerAddress (RemoteServerHostAddress hostname port) = do + let addrHints = defaultHints { addrSocketType = Stream } + hostAddrs <- getAddrInfo (Just addrHints) (Just hostname) (Just (show port)) + case hostAddrs of + [] -> error "getAddrInfo returned zero matches" + (AddrInfo _flags family socketType proto sockAddr _canonicalName:_) -> do + let sockSpec = SockSpec { sockFamily = family, + sockType = socketType, + sockProto = proto, + sockOpts = [] } + pure (sockSpec, sockAddr) +resolveRemoteServerAddress (RemoteServerUnixDomainSocketAddress sockPath) = do + let sockSpec = SockSpec { sockFamily = AF_UNIX, + sockType = Stream, + sockProto = 0, + sockOpts = [] } + sockAddr = SockAddrUnix sockPath + pure (sockSpec, sockAddr) -- | To create a 'Connection' to a remote or local database, create a 'ConnectionInfo' and call 'connectProjectM36'. connectProjectM36 :: ConnectionInfo -> IO (Either ConnectionError Connection) @@ -294,36 +327,25 @@ MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshGraph notificationCallback ghcPkgPaths CrashSafePersistence dbdir -> connectPersistentProjectM36 strat FsyncDiskSync dbdir freshGraph notificationCallback ghcPkgPaths -connectProjectM36 (RemoteConnectionInfo dbName hostName servicePort notificationCallback) = do - --TODO- add notification callback thread - let resolutionHints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV], - addrSocketType = Stream - } - resolved <- getAddrInfo (Just resolutionHints) (Just hostName) (Just servicePort) - case resolved of - [] -> error ("DNS resolution failed for" <> hostName <> ":" <> servicePort) - addrInfo:_ -> do - --supports IPv4 only for now - let (port, addr) = case addrAddress addrInfo of - SockAddrInet p a -> (p, a) - _ -> error "no IPv4 address available (IPv6 not implemented)" - notificationHandlers = - [RPC.ClientAsyncRequestHandler $ - \(NotificationMessage notifications') -> - forM_ (M.toList notifications') (uncurry notificationCallback) - ] - let connectExcHandler (e :: IOException) = pure $ Left (IOExceptionError e) - eConn <- (Right <$> RPC.connect notificationHandlers (hostAddressToTuple addr) port) `catch` connectExcHandler - case eConn of - Left err -> pure (Left err) - Right conn -> do - eRet <- RPC.call conn (Login dbName) - case eRet of - Left err -> error (show err) - Right False -> error "wtf" - Right True -> +connectProjectM36 (RemoteConnectionInfo dbName remoteAddress notificationCallback) = do + (sockSpec, sockAddr) <- resolveRemoteServerAddress remoteAddress + let notificationHandlers = + [RPC.ClientAsyncRequestHandler $ + \(NotificationMessage notifications') -> + forM_ (M.toList notifications') (uncurry notificationCallback) + ] + connectExcHandler (e :: IOException) = pure $ Left (IOExceptionError e) + eConn <- (Right <$> RPC.connect notificationHandlers sockSpec sockAddr) `catch` connectExcHandler + case eConn of + Left err -> pure (Left err) + Right conn -> do + eRet <- RPC.call conn (Login dbName) + case eRet of + Left err -> error (show err) + Right False -> error "wtf" + Right True -> --TODO handle connection errors! - pure (Right (RemoteConnection (RemoteConnectionConf conn))) + pure (Right (RemoteConnection (RemoteConnectionConf conn))) --convert RPC errors into exceptions convertRPCErrors :: RPC.ConnectionError -> IO a @@ -876,7 +898,18 @@ Right (session, _) -> pure (DCF.databaseContextFunctionsAsRelation (dbcFunctions (concreteDatabaseContext session))) -databaseContextFunctionsAsRelation sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveDatabaseContextFunctionSummary sessionId) +databaseContextFunctionsAsRelation sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveDatabaseContextFunctionSummary sessionId) + +notificationsAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation) +notificationsAsRelation sessionId (InProcessConnection conf) = do + let sessions = ipSessions conf + atomically $ do + eSession <- sessionAndSchema sessionId sessions + case eSession of + Left err -> pure (Left err) + Right (session, schema) -> + pure (Schema.notificationsAsRelationInSchema (notifications (concreteDatabaseContext session)) schema) +notificationsAsRelation sessionId conn@RemoteConnection{} = remoteCall conn (RetrieveNotificationsAsRelation sessionId) -- | Returns the transaction id for the connection's disconnected transaction committed parent transaction. headTransactionId :: SessionId -> Connection -> IO (Either RelationalError TransactionId) diff --git a/src/lib/ProjectM36/Error.hs b/src/lib/ProjectM36/Error.hs --- a/src/lib/ProjectM36/Error.hs +++ b/src/lib/ProjectM36/Error.hs @@ -84,6 +84,7 @@ | RelationValuedAttributesNotSupportedError [AttributeName] | NotificationNameInUseError NotificationName | NotificationNameNotInUseError NotificationName + | NotificationValidationError NotificationName NotificationExpression RelationalError | ImportError ImportError' | ExportError T.Text | UnhandledExceptionError String diff --git a/src/lib/ProjectM36/IsomorphicSchema.hs b/src/lib/ProjectM36/IsomorphicSchema.hs --- a/src/lib/ProjectM36/IsomorphicSchema.hs +++ b/src/lib/ProjectM36/IsomorphicSchema.hs @@ -15,6 +15,7 @@ import qualified Data.Vector as V import qualified ProjectM36.Attribute as A import ProjectM36.AtomType +import Data.Text (Text) #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif @@ -415,3 +416,31 @@ instance Morph GraphRefRelationalExpr where -- cannot be supported because we don't track how the schema changes over the lifetime of a transaction graph -} + +notificationsAsRelationInSchema :: Notifications -> Schema -> Either RelationalError Relation +notificationsAsRelationInSchema notifs schema = do + let attrs = A.attributesFromList [Attribute "name" TextAtomType, + Attribute "changeExpr" RelationalExprAtomType, + Attribute "reportOldExpr" RelationalExprAtomType, + Attribute "reportNewExpr" RelationalExprAtomType] + relExprT = processRelationalExprInSchema schema + transform (name, e1, e2, e3) = do + e1' <- relExprT e1 + e2' <- relExprT e2 + e3' <- relExprT e3 + pure (name, e1', e2', e3') + notifsData <- mapM transform (notificationsAsData notifs) + let mkRow (name, changeE, oldE, newE) = [TextAtom name, + RelationalExprAtom changeE, + RelationalExprAtom oldE, + RelationalExprAtom newE] + mkRelationFromList attrs (map mkRow notifsData) + +notificationsAsData :: Notifications -> [(Text, RelationalExpr, RelationalExpr, RelationalExpr)] +notificationsAsData notifs = + map mkRow (M.toList notifs) + where + mkRow (name, notif) = (name, + changeExpr notif, + reportOldExpr notif, + reportNewExpr notif) diff --git a/src/lib/ProjectM36/RelationalExpression.hs b/src/lib/ProjectM36/RelationalExpression.hs --- a/src/lib/ProjectM36/RelationalExpression.hs +++ b/src/lib/ProjectM36/RelationalExpression.hs @@ -22,7 +22,7 @@ import qualified Data.Map as M import qualified Data.HashSet as HS import qualified Data.Set as S -import Control.Monad (foldM, unless, when) +import Control.Monad (foldM, unless, when, forM_) import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError, catchError) import Control.Monad.Reader (ReaderT, runReaderT, asks, ask, local) import qualified Control.Monad.Reader as R @@ -382,15 +382,20 @@ -- | Add a notification which will send the resultExpr when triggerExpr changes between commits. evalGraphRefDatabaseContextExpr (AddNotification notName triggerExpr resultOldExpr resultNewExpr) = do currentContext <- getStateContext + graph <- dbcGraph + transId <- dbcTransId let nots = notifications currentContext if M.member notName nots then dbErr (NotificationNameInUseError notName) else do - let newNotifications = M.insert notName newNotification nots - newNotification = Notification { changeExpr = triggerExpr, + let newNotification = Notification { changeExpr = triggerExpr, reportOldExpr = resultOldExpr, reportNewExpr = resultNewExpr} - putStateContext $ currentContext { notifications = newNotifications } + newNotifications = M.insert notName newNotification nots + potentialContext = currentContext { notifications = newNotifications } + case checkConstraints potentialContext transId graph of + Left err -> dbErr err + Right () -> putStateContext potentialContext evalGraphRefDatabaseContextExpr (RemoveNotification notName) = do currentContext <- getStateContext @@ -693,6 +698,7 @@ checkConstraints context transId graph@(TransactionGraph graphHeads transSet) = do mapM_ (uncurry checkIncDep) (M.toList deps) mapM_ checkRegisteredQuery (M.toList (registeredQueries context)) + mapM_ checkNotification (M.toList (notifications context)) where potentialGraph = TransactionGraph graphHeads (S.insert tempTrans transSet) tempStamp = UTCTime { utctDay = fromGregorian 2000 1 1, @@ -734,6 +740,18 @@ case runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr) of Left err -> Left (RegisteredQueryValidationError qName err) Right _ -> pure () + checkRelExpr relExpr = do + let gfExpr = process (processRelationalExpr relExpr) + runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr) + checkNotification (notName, notif) = do + forM_ [(NotificationChangeExpression, changeExpr notif), + (NotificationReportOldExpression, reportOldExpr notif), + (NotificationReportNewExpression, reportNewExpr notif)] $ + \(typ, relExpr) -> do + case checkRelExpr relExpr of + Left err -> Left (NotificationValidationError notName typ err) + Right _ -> pure () + -- the type of a relational expression is equal to the relation attribute set returned from executing the relational expression; therefore, the type can be cheaply derived by evaluating a relational expression and ignoring and tuple processing -- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation @@ -1582,3 +1600,13 @@ where targetAttrExprs = map NakedAttributeExpr (A.toList targetAttrs) hint = addTargetTypeHints targetAttrs + +-- | Ensure that the notification contains valid, type-checkable relational expressions. These relational expressions therefore become registered queries: queries which must remain valid. +validateNotification :: Notification -> DatabaseContext -> TransactionGraph -> Either RelationalError Notification +validateNotification notif context graph = do + let reEnv = mkRelationalExprEnv context graph + runRelationalExprM reEnv $ do + _ <- typeForRelationalExpr (changeExpr notif) + _ <- typeForRelationalExpr (reportOldExpr notif) + _ <- typeForRelationalExpr (reportNewExpr notif) + pure notif diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -1032,7 +1032,7 @@ PrefixOperator _ e1 -> rec' e1 PostfixOperator e1 _ -> rec' e1 BetweenOperator e1 _ e2 -> rec' e1 || rec' e2 - FunctionApplication _ e1 -> or (rec' <$> e1) + FunctionApplication _ e1 -> any rec' e1 CaseExpr cases else' -> any (\(when', then') -> rec' when' || rec' then' || maybe False rec' else') cases QuantifiedComparison{} -> True diff --git a/src/lib/ProjectM36/Serialise/Base.hs b/src/lib/ProjectM36/Serialise/Base.hs --- a/src/lib/ProjectM36/Serialise/Base.hs +++ b/src/lib/ProjectM36/Serialise/Base.hs @@ -49,6 +49,7 @@ deriving via WineryVariant (ExtendTupleExprBase a) instance Serialise a => Serialise (ExtendTupleExprBase a) deriving via WineryVariant Schema instance Serialise Schema deriving via WineryVariant MergeStrategy instance Serialise MergeStrategy +deriving via WineryVariant NotificationExpression instance Serialise NotificationExpression fromWordsTup :: (Word32, Word32, Word32, Word32) -> TransactionId fromWordsTup (a,b,c,d) = fromWords a b c d diff --git a/src/lib/ProjectM36/Server.hs b/src/lib/ProjectM36/Server.hs --- a/src/lib/ProjectM36/Server.hs +++ b/src/lib/ProjectM36/Server.hs @@ -117,7 +117,10 @@ handleConvertSQLQuery ti sessionId conn q), RequestHandler (\sState (ConvertSQLUpdates sessionId updates) -> do conn <- getConn sState - handleConvertSQLUpdates ti sessionId conn updates) + handleConvertSQLUpdates ti sessionId conn updates), + RequestHandler (\sState (RetrieveNotificationsAsRelation sessionId) -> do + conn <- getConn sState + handleRetrieveNotificationsAsRelation ti sessionId conn) ] ++ if testFlag then testModeHandlers ti else [] getConn :: ConnectionState ServerState -> IO Connection @@ -197,6 +200,7 @@ clientMap <- StmMap.new StmMap.insert conn dbName dbmap pure (ServerState { stateDBMap = dbmap, stateClientMap = clientMap }) + -- | 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. launchServer :: ServerConfig -> Maybe (MVar SockAddr) -> IO Bool launchServer daemonConfig mAddr = do @@ -211,22 +215,12 @@ hPutStrLn stderr ("Failed to create database connection: " ++ show err) pure False Right conn -> do - let hostname = bindHost daemonConfig - port = fromIntegral (bindPort daemonConfig) - + let mTimeout = fromIntegral <$> + case perRequestTimeout daemonConfig of + 0 -> Nothing + v -> Just v + (sockSpec, sockAddr) <- resolveRemoteServerAddress (bindAddress daemonConfig) + sState <- initialServerState (databaseName daemonConfig) conn + serve (requestHandlers (testMode daemonConfig) mTimeout) sState sockSpec sockAddr mAddr - --curryer only supports IPv4 for now - let addrHints = defaultHints { addrSocketType = Stream, addrFamily = AF_INET } - hostAddrs <- getAddrInfo (Just addrHints) (Just hostname) Nothing - case hostAddrs of - [] -> hPutStrLn stderr ("Failed to resolve: " <> hostname) >> pure False - (AddrInfo _ _ _ _ (SockAddrInet _ addr32) _):_ -> do - let hostAddr = hostAddressToTuple addr32 - mTimeout = fromIntegral <$> case perRequestTimeout daemonConfig of - 0 -> Nothing - v -> Just v - - sState <- initialServerState (databaseName daemonConfig) conn - serve (requestHandlers (testMode daemonConfig) mTimeout) sState hostAddr port mAddr - _ -> error "unsupported socket addressing mode (IPv4 only currently)" diff --git a/src/lib/ProjectM36/Server/Config.hs b/src/lib/ProjectM36/Server/Config.hs --- a/src/lib/ProjectM36/Server/Config.hs +++ b/src/lib/ProjectM36/Server/Config.hs @@ -4,8 +4,7 @@ data ServerConfig = ServerConfig { persistenceStrategy :: PersistenceStrategy, checkFS :: Bool, databaseName :: DatabaseName, - bindHost :: Hostname, - bindPort :: Port, + bindAddress :: RemoteServerAddress, ghcPkgPaths :: [String], -- used for AtomFunction dynamic compilation perRequestTimeout :: Int, testMode :: Bool -- used exclusively for automated testing of the server, thus not accessible from the command line @@ -19,12 +18,12 @@ deriving (Show) defaultServerConfig :: ServerConfig -defaultServerConfig = ServerConfig { persistenceStrategy = NoPersistence, - checkFS = True, - databaseName = "base", - bindHost = "127.0.0.1", - bindPort = 6543, - ghcPkgPaths = [], - perRequestTimeout = 0, - testMode = False - } +defaultServerConfig = + ServerConfig { persistenceStrategy = NoPersistence, + checkFS = True, + databaseName = "base", + bindAddress = RemoteServerHostAddress "127.0.0.1" 6543, + ghcPkgPaths = [], + perRequestTimeout = 0, + testMode = False + } diff --git a/src/lib/ProjectM36/Server/EntryPoints.hs b/src/lib/ProjectM36/Server/EntryPoints.hs --- a/src/lib/ProjectM36/Server/EntryPoints.hs +++ b/src/lib/ProjectM36/Server/EntryPoints.hs @@ -165,3 +165,7 @@ handleConvertSQLUpdates :: Maybe Timeout -> SessionId -> Connection -> [DBUpdate] -> IO (Either RelationalError DatabaseContextExpr) handleConvertSQLUpdates ti sessionId conn ups = timeoutRelErr ti (C.convertSQLDBUpdates sessionId conn ups) + +handleRetrieveNotificationsAsRelation :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Relation) +handleRetrieveNotificationsAsRelation ti sessionId conn = + timeoutRelErr ti (C.notificationsAsRelation sessionId conn) diff --git a/src/lib/ProjectM36/Server/ParseArgs.hs b/src/lib/ProjectM36/Server/ParseArgs.hs --- a/src/lib/ProjectM36/Server/ParseArgs.hs +++ b/src/lib/ProjectM36/Server/ParseArgs.hs @@ -12,8 +12,7 @@ parsePersistenceStrategy <*> parseCheckFS <*> parseDatabaseName <*> - parseHostname (bindHost defaults) <*> - parsePort (bindPort defaults) <*> + parseServerAddress <*> many parseGhcPkgPath <*> parseTimeout (perRequestTimeout defaults) <*> parseTestMode @@ -38,6 +37,19 @@ parseCheckFS :: Parser Bool parseCheckFS = flag True False (long "disable-fscheck" <> help "Disable filesystem check for journaling.") + +parseServerAddress :: Parser RemoteServerAddress +parseServerAddress = + (RemoteServerHostAddress <$> + parseHostname "127.0.0.1" <*> + parsePort 6543) + <|> + (RemoteServerUnixDomainSocketAddress <$> parseUnixDomainSocketPath) + +parseUnixDomainSocketPath :: Parser FilePath +parseUnixDomainSocketPath = strOption (short 'x' <> + long "unix-domain-socket" <> + metavar "SOCKET_PATH") parseDatabaseName :: Parser DatabaseName parseDatabaseName = strOption (short 'n' <> diff --git a/src/lib/ProjectM36/Server/RemoteCallTypes.hs b/src/lib/ProjectM36/Server/RemoteCallTypes.hs --- a/src/lib/ProjectM36/Server/RemoteCallTypes.hs +++ b/src/lib/ProjectM36/Server/RemoteCallTypes.hs @@ -76,6 +76,9 @@ data RetrieveAtomTypesAsRelation = RetrieveAtomTypesAsRelation SessionId RPCData(RetrieveAtomTypesAsRelation) + +data RetrieveNotificationsAsRelation = RetrieveNotificationsAsRelation SessionId + RPCData(RetrieveNotificationsAsRelation) data RetrieveRelationVariableSummary = RetrieveRelationVariableSummary SessionId RPCData(RetrieveRelationVariableSummary) diff --git a/test/Server/Main.hs b/test/Server/Main.hs --- a/test/Server/Main.hs +++ b/test/Server/Main.hs @@ -65,7 +65,7 @@ testConnection :: Port -> MVar () -> IO (Either ConnectionError (SessionId, Connection)) testConnection serverPort mvar = do - let connInfo = RemoteConnectionInfo testDatabaseName "127.0.0.1" (show serverPort) (testNotificationCallback mvar) + let connInfo = RemoteConnectionInfo testDatabaseName (RemoteServerHostAddress "127.0.0.1" serverPort) (testNotificationCallback mvar) --putStrLn ("testConnection: " ++ show serverAddress) eConn <- connectProjectM36 connInfo case eConn of @@ -86,7 +86,7 @@ persistenceStrategy = CrashSafePersistence (tempdir "db"), perRequestTimeout = ti, testMode = True, - bindPort = 0, + bindAddress = RemoteServerHostAddress "127.0.0.1" 0, checkFS = False --not stricly needed for these tests } @@ -242,7 +242,7 @@ testClientConnectFail :: Test testClientConnectFail = TestCase $ do - let connInfo = RemoteConnectionInfo "nonexistentdb" "127.0.0.1" "7777" emptyNotificationCallback + let connInfo = RemoteConnectionInfo "nonexistentdb" (RemoteServerHostAddress "127.0.0.1" 7777) emptyNotificationCallback eConn <- connectProjectM36 connInfo case eConn of Left (IOExceptionError _) -> pure () diff --git a/test/Server/WebSocket.hs b/test/Server/WebSocket.hs --- a/test/Server/WebSocket.hs +++ b/test/Server/WebSocket.hs @@ -26,7 +26,7 @@ launchTestServer = do addressMVar <- newEmptyMVar let config = defaultServerConfig { databaseName = testDatabaseName, - bindPort = 0, + bindAddress = RemoteServerHostAddress "127.0.0.1" 0, checkFS = False} testDatabaseName = "test" -- start normal server diff --git a/test/TutorialD/InterpreterTest.hs b/test/TutorialD/InterpreterTest.hs --- a/test/TutorialD/InterpreterTest.hs +++ b/test/TutorialD/InterpreterTest.hs @@ -54,7 +54,6 @@ transactionJumpTest, transactionBranchTest, simpleJoinTest, - testNotification, testTypeConstructors, testMergeTransactions, testComments, @@ -96,7 +95,9 @@ testRegisteredQueries, testCrossJoin, testIfThenExpr, - testSubrelationAttributeAtomExpr + testSubrelationAttributeAtomExpr, + testComplexTypeVarResolution, + testNotifications ] simpleRelTests :: Test @@ -335,8 +336,8 @@ -} -- test notifications over the InProcessConnection -testNotification :: Test -testNotification = TestCase $ do +testNotifications :: Test +testNotifications = TestCase $ do notifmvar <- newEmptyMVar let notifCallback mvar _ _ = putMVar mvar () relvarx = RelationVariable "x" () @@ -347,7 +348,17 @@ executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationFalse)) >>= eitherFail commit sess conn >>= eitherFail takeMVar notifmvar - + + -- test documented behavior + let notifCallback2 name _evald = + assertEqual "notification" "steve_change" name + (session, dbconn) <- dateExamplesConnection notifCallback2 + executeTutorialD session dbconn "person:=relation{tuple{name \"Steve\",address \"Main St.\"},tuple{name \"John\", address \"Elm St.\"}}" + executeTutorialD session dbconn "notify steve_change person where name=\"Steve\" true (person where name=\"Steve\"){address}" + _ <- commit session dbconn + executeTutorialD session dbconn "update person where name=\"Steve\" (address:=\"Grove St.\")" + expectTutorialDErr session dbconn (T.isPrefixOf "NotificationValidationError") "undefine person" + testTypeConstructors :: Test testTypeConstructors = TestCase $ do (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback @@ -886,3 +897,32 @@ executeTutorialD session dbconn "z:= x = y" res <- executeRelationalExpr session dbconn (RelationVariable "z" ()) assertEqual "sum" (Right relationTrue) res + +testComplexTypeVarResolution :: Test +testComplexTypeVarResolution = TestCase $ do + (session, dbconn) <- dateExamplesConnection emptyNotificationCallback + executeTutorialD session dbconn "data F = F (Maybe Integer) (Maybe Integer)" + executeTutorialD session dbconn "x:=relation{x F}{tuple{x F Nothing (Just 4)}}" + executeTutorialD session dbconn "y:=relation{x F}{tuple{x F Nothing Nothing}}" + + resX <- executeRelationalExpr session dbconn (RelationVariable "x" ()) + resY <- executeRelationalExpr session dbconn (RelationVariable "y" ()) + + + let expectedX = mkRelationFromList attrs + [[ConstructedAtom "F" + (ConstructedAtomType "F" mempty) + [ConstructedAtom "Nothing" mint [], + ConstructedAtom "Just" mint [IntegerAtom 4]]]] + attrs = A.attributesFromList [Attribute "x" (ConstructedAtomType "F" mempty)] + mint = ConstructedAtomType "Maybe" (M.singleton "a" IntegerAtomType) + assertEqual "type var resolution x" expectedX resX + + let expectedY = mkRelationFromList attrs + [[ConstructedAtom "F" + (ConstructedAtomType "F" mempty) + [ConstructedAtom "Nothing" mint [], + ConstructedAtom "Nothing" mint []]]] + + assertEqual "type var resolution y" expectedY resY +