From 701bad8b2130709e1efef09c1e9f6865055df753 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Sat, 5 Mar 2022 14:50:52 +0100 Subject: [PATCH 01/51] Disabled not useful parts of the navigation --- IHP/IDE/ToolServer/Layout.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/IHP/IDE/ToolServer/Layout.hs b/IHP/IDE/ToolServer/Layout.hs index 78d154007..6f6449455 100644 --- a/IHP/IDE/ToolServer/Layout.hs +++ b/IHP/IDE/ToolServer/Layout.hs @@ -56,12 +56,8 @@ toolServerLayout inner = H.docTypeHtml ! A.lang "en" $ [hsx| {apps} {schema} {data_} - {codegen} {logs} - {deploy} - {docu} - {when isBasicEdition getPro} {help} ©
digitally induced GmbH From e0e322c8592f65e8d49110b6e7ccfd23e94ab6eb Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Sat, 5 Mar 2022 16:32:16 +0100 Subject: [PATCH 02/51] Added input types to graphql schema --- IHP/GraphQL/SchemaCompiler.hs | 19 ++++++++++++++++--- IHP/GraphQL/ToText.hs | 9 +++++++++ IHP/GraphQL/Types.hs | 2 +- Test/GraphQL/SchemaCompilerSpec.hs | 21 +++++++++++++++++---- 4 files changed, 43 insertions(+), 8 deletions(-) diff --git a/IHP/GraphQL/SchemaCompiler.hs b/IHP/GraphQL/SchemaCompiler.hs index 6e4bd61b5..8ddbfd1b6 100644 --- a/IHP/GraphQL/SchemaCompiler.hs +++ b/IHP/GraphQL/SchemaCompiler.hs @@ -18,6 +18,7 @@ sqlSchemaToGraphQLSchema statements = <> customScalars <> recordTypes statements <> newRecordTypes statements + <> patchTypes statements schemaDefinition :: Definition schemaDefinition = @@ -83,7 +84,7 @@ statementToMutationFields (StatementCreateTable CreateTable { name }) = , name = "update" <> tableNameToModelName name , argumentsDefinition = [ ArgumentDefinition { name = "id", argumentType = NonNullType (NamedType "ID"), defaultValue = Nothing } - , ArgumentDefinition { name = "patch", argumentType = NonNullType (NamedType (tableNameToModelName name)), defaultValue = Nothing } + , ArgumentDefinition { name = "patch", argumentType = NonNullType (NamedType ((tableNameToModelName name) <> "Patch")), defaultValue = Nothing } ] , type_ = NonNullType (NamedType (tableNameToModelName name)) } @@ -133,13 +134,25 @@ newRecordType schema (StatementCreateTable table@(CreateTable { name, columns }) Just TypeSystemDefinition { typeSystemDefinition = TypeDefinition typeDefinition } where typeDefinition = - ObjectTypeDefinition + InputObjectTypeDefinition { name = "New" <> tableNameToModelName name - , implementsInterfaces = [] , fieldDefinitions = map (columnToRecordField table) columns } newRecordType _ _ = Nothing +patchTypes :: [Statement] -> [Definition] +patchTypes statements = mapMaybe (patchType statements) statements + +patchType :: SqlSchema -> Statement -> Maybe Definition +patchType schema (StatementCreateTable table@(CreateTable { name, columns })) = + Just TypeSystemDefinition { typeSystemDefinition = TypeDefinition typeDefinition } + where + typeDefinition = + InputObjectTypeDefinition + { name = tableNameToModelName name <> "Patch" + , fieldDefinitions = map (columnToRecordField table) columns + } +patchType _ _ = Nothing columnToRecordField :: CreateTable -> Column -> FieldDefinition columnToRecordField table Column { name, columnType, notNull } = diff --git a/IHP/GraphQL/ToText.hs b/IHP/GraphQL/ToText.hs index 10af7ae7b..16c08d430 100644 --- a/IHP/GraphQL/ToText.hs +++ b/IHP/GraphQL/ToText.hs @@ -47,6 +47,15 @@ typeDefinitionToText ObjectTypeDefinition { name, implementsInterfaces, fieldDef fields = fieldDefinitions |> map fieldDefinitionToText |> Text.intercalate "\n" +typeDefinitionToText InputObjectTypeDefinition { name, fieldDefinitions } = [trimming| + input $name { + $fields + } +|] + where + fields = fieldDefinitions + |> map fieldDefinitionToText + |> Text.intercalate "\n" fieldDefinitionToText :: FieldDefinition -> Text fieldDefinitionToText FieldDefinition { description, name, argumentsDefinition, type_ } = diff --git a/IHP/GraphQL/Types.hs b/IHP/GraphQL/Types.hs index fca5350b4..16d23022a 100644 --- a/IHP/GraphQL/Types.hs +++ b/IHP/GraphQL/Types.hs @@ -35,7 +35,7 @@ data TypeDefinition | InterfaceTypeDefinition | UnionTypeDefinition | EnumTypeDefinition - | InputObjectTypeDefinition + | InputObjectTypeDefinition { name :: !Text, fieldDefinitions :: ![FieldDefinition] } deriving (Eq, Show) data OperationDefinition diff --git a/Test/GraphQL/SchemaCompilerSpec.hs b/Test/GraphQL/SchemaCompilerSpec.hs index 7ccfa01d3..d47a0409c 100644 --- a/Test/GraphQL/SchemaCompilerSpec.hs +++ b/Test/GraphQL/SchemaCompilerSpec.hs @@ -57,10 +57,10 @@ tests = do } type Mutation { createUser(user: NewUser!): User! - updateUser(id: ID!, patch: User!): User! + updateUser(id: ID!, patch: UserPatch!): User! deleteUser(id: ID!): User! createTask(task: NewTask!): Task! - updateTask(id: ID!, patch: Task!): Task! + updateTask(id: ID!, patch: TaskPatch!): Task! deleteTask(id: ID!): Task! } scalar UUID @@ -79,14 +79,27 @@ tests = do body: String! userId: UUID! } - type NewUser { + input NewUser { id: ID! email: String! passwordHash: String! lockedAt: Timestamp failedLoginAttempts: Int! } - type NewTask { + input NewTask { + id: ID! + title: String! + body: String! + userId: UUID! + } + input UserPatch { + id: ID! + email: String! + passwordHash: String! + lockedAt: Timestamp + failedLoginAttempts: Int! + } + input TaskPatch { id: ID! title: String! body: String! From 466ebb7aec0b47dc9d5a30533c7b257b02ba42a7 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Sun, 6 Mar 2022 15:37:41 +0100 Subject: [PATCH 03/51] Added missing modules to cabal file --- ihp.cabal | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/ihp.cabal b/ihp.cabal index ef83a38e5..d55ac1d24 100644 --- a/ihp.cabal +++ b/ihp.cabal @@ -378,6 +378,12 @@ library , IHP.IDE.SchemaDesigner.Compiler , IHP.IDE.SchemaDesigner.Parser , IHP.IDE.SchemaDesigner.Types + , IHP.GraphQL.Compiler + , IHP.GraphQL.JSON + , IHP.GraphQL.Parser + , IHP.GraphQL.SchemaCompiler + , IHP.GraphQL.ToText + , IHP.GraphQL.Types executable RunDevServer import: shared-properties From f5045c180b80674e92341d8285ae230a401dff10 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Tue, 8 Mar 2022 10:16:57 +0100 Subject: [PATCH 04/51] Initial prototype of the standalone GraphQL edition of IHP --- IHP/Controller/Redirect.hs | 17 +- IHP/IDE/Graph/Controller.hs | 26 + IHP/IDE/Graph/View/Explore.hs | 18 + IHP/IDE/Graph/View/Layout.hs | 45 + IHP/IDE/Graph/View/Schema.hs | 18 + IHP/IDE/ToolServer.hs | 10 +- IHP/IDE/ToolServer/Layout.hs | 90 +- IHP/IDE/ToolServer/Routes.hs | 3 +- IHP/IDE/ToolServer/Types.hs | 5 + NixSupport/default.nix | 7 +- ihp.cabal | 4 + ihp.nix | 4 +- lib/IHP/static/IDE/Graph/app.jsx | 89 + lib/IHP/static/IDE/Graph/graph.css | 56 + lib/IHP/static/IDE/Graph/package-lock.json | 3296 ++++++++++++++++++++ lib/IHP/static/IDE/Graph/package.json | 22 + lib/IHP/static/IDE/Graph/solarized.css | 165 + lib/IHP/static/IDE/clipboard.js | 4 + lib/IHP/static/vendor/clipboard.min.js | 7 + 19 files changed, 3874 insertions(+), 12 deletions(-) create mode 100644 IHP/IDE/Graph/Controller.hs create mode 100644 IHP/IDE/Graph/View/Explore.hs create mode 100644 IHP/IDE/Graph/View/Layout.hs create mode 100644 IHP/IDE/Graph/View/Schema.hs create mode 100644 lib/IHP/static/IDE/Graph/app.jsx create mode 100644 lib/IHP/static/IDE/Graph/graph.css create mode 100644 lib/IHP/static/IDE/Graph/package-lock.json create mode 100644 lib/IHP/static/IDE/Graph/package.json create mode 100644 lib/IHP/static/IDE/Graph/solarized.css create mode 100644 lib/IHP/static/IDE/clipboard.js create mode 100644 lib/IHP/static/vendor/clipboard.min.js diff --git a/IHP/Controller/Redirect.hs b/IHP/Controller/Redirect.hs index 8d8754f45..4d41db7a7 100644 --- a/IHP/Controller/Redirect.hs +++ b/IHP/Controller/Redirect.hs @@ -18,6 +18,7 @@ import IHP.Controller.RequestContext import IHP.RouterSupport (HasPath (pathTo)) import IHP.FrameworkConfig import Network.HTTP.Types.Status +import qualified Network.Wai as Wai import IHP.Controller.Context import IHP.ControllerSupport @@ -43,7 +44,7 @@ redirectTo action = redirectToPath (pathTo action) -- -- Use 'redirectTo' if you want to redirect to a controller action. redirectToPath :: (?context :: ControllerContext) => Text -> IO () -redirectToPath path = redirectToUrl (fromConfig baseUrl <> path) +redirectToPath path = redirectToUrl (appHost <> path) {-# INLINABLE redirectToPath #-} -- | Redirects to a url (given as a string) @@ -65,6 +66,20 @@ redirectToUrl url = do respondAndExit redirectResponse {-# INLINABLE redirectToUrl #-} +appHost :: (?context :: ControllerContext) => Text +appHost = + let + request = ?context + |> get #requestContext + |> get #request + protocol = if Wai.isSecure request + then "https" + else "http" + in request + |> Wai.requestHeaderHost + |> \case + Just host -> protocol <> "://" <> cs host + Nothing -> fromConfig baseUrl -- | Redirects back to the last page -- diff --git a/IHP/IDE/Graph/Controller.hs b/IHP/IDE/Graph/Controller.hs new file mode 100644 index 000000000..4c05c3dd9 --- /dev/null +++ b/IHP/IDE/Graph/Controller.hs @@ -0,0 +1,26 @@ +module IHP.IDE.Graph.Controller where + +import IHP.ControllerPrelude +import IHP.IDE.ToolServer.Types + +import IHP.IDE.Graph.View.Explore +import IHP.IDE.Graph.View.Schema + +import qualified IHP.IDE.SchemaDesigner.Parser as SchemaDesigner +import qualified IHP.GraphQL.ToText as GraphQL +import qualified IHP.GraphQL.SchemaCompiler as GraphQL + +instance Controller GraphController where + action ExploreAction = do + SchemaDesigner.parseSchemaSql >>= \case + Left parserError -> fail (cs parserError) + Right sqlSchema -> do + let schema = GraphQL.sqlSchemaToGraphQLSchema sqlSchema + render ExploreView { .. } + + action SchemaAction = do + SchemaDesigner.parseSchemaSql >>= \case + Left parserError -> fail (cs parserError) + Right sqlSchema -> do + let schema = GraphQL.sqlSchemaToGraphQLSchema sqlSchema + render SchemaView { .. } diff --git a/IHP/IDE/Graph/View/Explore.hs b/IHP/IDE/Graph/View/Explore.hs new file mode 100644 index 000000000..e73145de4 --- /dev/null +++ b/IHP/IDE/Graph/View/Explore.hs @@ -0,0 +1,18 @@ +module IHP.IDE.Graph.View.Explore where + +import IHP.ViewPrelude +import IHP.IDE.ToolServer.Types +import qualified IHP.GraphQL.Types as GraphQL +import qualified IHP.GraphQL.SchemaCompiler as GraphQL +import qualified IHP.GraphQL.ToText as GraphQL +import IHP.IDE.Graph.View.Layout + +data ExploreView + = ExploreView + { schema :: GraphQL.GraphQLSchema } + +instance View ExploreView where + html ExploreView { .. } = [hsx| + {headerNav} +
+ |] \ No newline at end of file diff --git a/IHP/IDE/Graph/View/Layout.hs b/IHP/IDE/Graph/View/Layout.hs new file mode 100644 index 000000000..3d24670e5 --- /dev/null +++ b/IHP/IDE/Graph/View/Layout.hs @@ -0,0 +1,45 @@ +module IHP.IDE.Graph.View.Layout +( headerNav +) where + +import IHP.ViewPrelude +import IHP.IDE.ToolServer.Types +import IHP.IDE.ToolServer.Routes +import qualified Data.Text as Text +import IHP.IDE.ToolServer.Helper.View + +headerNav :: Html +headerNav = [hsx| +
+
+ + Explore + + + + Schema + + +
+
+ {url} +
+
+
+
+|] + where + exploreActive :: Bool + exploreActive = isActivePath ExploreAction + + schemaActive :: Bool + schemaActive = isActivePath SchemaAction + + url :: Text + url = "http://localhost:8000/api/graphql" \ No newline at end of file diff --git a/IHP/IDE/Graph/View/Schema.hs b/IHP/IDE/Graph/View/Schema.hs new file mode 100644 index 000000000..c7c2d23ba --- /dev/null +++ b/IHP/IDE/Graph/View/Schema.hs @@ -0,0 +1,18 @@ +module IHP.IDE.Graph.View.Schema where + +import IHP.ViewPrelude +import IHP.IDE.ToolServer.Types +import qualified IHP.GraphQL.Types as GraphQL +import qualified IHP.GraphQL.SchemaCompiler as GraphQL +import qualified IHP.GraphQL.ToText as GraphQL +import IHP.IDE.Graph.View.Layout + +data SchemaView + = SchemaView + { schema :: GraphQL.GraphQLSchema } + +instance View SchemaView where + html SchemaView { .. } = [hsx| + {headerNav} + 
{GraphQL.toText schema}
+ |] \ No newline at end of file diff --git a/IHP/IDE/ToolServer.hs b/IHP/IDE/ToolServer.hs index acbb5297d..abc9b1786 100644 --- a/IHP/IDE/ToolServer.hs +++ b/IHP/IDE/ToolServer.hs @@ -30,6 +30,7 @@ import IHP.IDE.SchemaDesigner.Controller.Migrations () import IHP.IDE.Data.Controller () import IHP.IDE.Logs.Controller () import IHP.IDE.CodeGen.Controller () +import IHP.IDE.Graph.Controller () import IHP.IDE.ToolServer.Types import IHP.IDE.ToolServer.Helper.Controller as Helper import IHP.IDE.ToolServer.Routes () @@ -73,7 +74,7 @@ startToolServer' port isDebugMode = do Nothing -> pure () session <- Vault.newKey - store <- fmap clientsessionStore (ClientSession.getKey "Config/client_session_key.aes") + store <- fmap clientsessionStore (ClientSession.getKeyEnv "Config/client_session_key.aes") let sessionMiddleware :: Wai.Middleware = withSession store "SESSION" (get #sessionCookie frameworkConfig) session let modelContext = notConnectedModelContext undefined pgListener <- PGListener.init modelContext @@ -92,7 +93,7 @@ startToolServer' port isDebugMode = do let openAppUrl = openUrl ("http://localhost:" <> tshow port <> "/") let warpSettings = Warp.defaultSettings |> Warp.setPort port - |> Warp.setBeforeMainLoop openAppUrl + -- |> Warp.setBeforeMainLoop openAppUrl let logMiddleware = if isDebugMode then get #requestLoggerMiddleware frameworkConfig else IHP.Prelude.id @@ -133,13 +134,14 @@ instance FrontController ToolServerApplication where , parseRoute @DataController , parseRoute @CodeGenController , parseRoute @MigrationsController + , parseRoute @GraphController , startPage TablesAction ] instance ControllerSupport.InitControllerContext ToolServerApplication where initContext = do - availableApps <- AvailableApps <$> findApplications - webControllers <- WebControllers <$> findWebControllers + let availableApps = AvailableApps ["Web"] + let webControllers = WebControllers [] let defaultAppUrl = "http://localhost:" <> tshow Helper.appPort appUrl :: Text <- fromMaybe defaultAppUrl <$> fmap cs <$> Env.lookupEnv "IHP_BASEURL" diff --git a/IHP/IDE/ToolServer/Layout.hs b/IHP/IDE/ToolServer/Layout.hs index 6f6449455..a3443c21a 100644 --- a/IHP/IDE/ToolServer/Layout.hs +++ b/IHP/IDE/ToolServer/Layout.hs @@ -19,6 +19,8 @@ toolServerLayout inner = H.docTypeHtml ! A.lang "en" $ [hsx| + + @@ -46,6 +48,11 @@ toolServerLayout inner = H.docTypeHtml ! A.lang "en" $ [hsx| + + + + + IHP IDE @@ -53,9 +60,9 @@ toolServerLayout inner = H.docTypeHtml ! A.lang "en" $ [hsx|