AirGQL: Clean up documentation, remove obsolete references to Airsequel

.gitignore

@@ -0,0 +1,5 @@
+.stack-work
+*.hie
+/bruno_collection
+/data
+/tests/*.db

Setup.hs

@@ -0,0 +1,4 @@
+import Distribution.Simple
+
+
+main = defaultMain

app/Main.hs

@@ -0,0 +1,218 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+-- To look up git hash
+{-# LANGUAGE TemplateHaskell #-}
+
+-- Necessary for cmdArgs
+{-# OPTIONS -Wno-partial-fields #-}
+
+module Main (main) where
+
+import Protolude (
+  Applicative (pure),
+  Eq ((==)),
+  FilePath,
+  IO,
+  Int,
+  Maybe (Just),
+  Semigroup ((<>)),
+  Show,
+  Text,
+  const,
+  putText,
+  repeat,
+  show,
+  ($),
+  (&),
+  (||),
+ )
+import Protolude qualified as P
+
+import Data.Data (Data)
+import Data.Text qualified as T
+import Database.SQLite.Simple qualified as SS
+import GitHash (giDirty, giTag, tGitInfoCwd)
+import Network.HTTP.Client.MultipartFormData ()
+import Network.Wai (Middleware)
+import Network.Wai.Handler.Warp (
+  defaultSettings,
+  runSettings,
+  setOnException,
+  setPort,
+ )
+import Network.Wai.Middleware.Cors (
+  cors,
+  corsMethods,
+  corsRequestHeaders,
+  simpleCorsResourcePolicy,
+  simpleMethods,
+ )
+import System.Console.CmdArgs as CmdArgs (
+  Default (def),
+  args,
+  auto,
+  cmdArgs,
+  help,
+  modes,
+  program,
+  summary,
+  typ,
+  (&=),
+ )
+
+import AirGQL.ExternalAppContext (getExternalAppContext)
+import AirGQL.Utils (
+  getGraphiQLVersion,
+  getSqliteBinaryVersion,
+  getSqliteEmbeddedVersion,
+ )
+import Server.Server (platformApp)
+
+
+data Cli
+  = Help
+  | Version
+  | -- Start the AirGQL server
+    -- serving the GraphQL endpoint for the specified SQLite database
+    Serve
+      { dbFilePath :: FilePath
+      -- TODO: , readOnly :: Bool
+      }
+  deriving (Show, Data)
+
+
+cliHelp :: Cli
+cliHelp =
+  Help
+    &= auto
+
+
+cliVersion :: Cli
+cliVersion = Version
+
+
+cliServe :: Cli
+cliServe =
+  Serve
+    { dbFilePath = def &= typ "Path to database file" &= args
+    -- TODO: , readOnly = def
+    }
+    &= help "Serve database via GraphQL"
+
+
+corsMiddleware :: Middleware
+corsMiddleware =
+  let
+    policy =
+      simpleCorsResourcePolicy
+        { corsRequestHeaders = ["Content-Type", "Authorization"]
+        , corsMethods = "PUT" : simpleMethods
+        }
+  in
+    cors (const $ Just policy)
+
+
+-- | Imitates output from `git describe --always --dirty`
+versionSlug :: Text
+versionSlug =
+  T.pack $
+    giTag $$tGitInfoCwd
+      <> (if giDirty $$tGitInfoCwd then "-dirty" else "")
+
+
+main :: IO ()
+main = do
+  let
+    port :: Int = 4189
+
+    separatorLine = "\n" <> T.concat (P.take 80 $ repeat "=")
+    separatorLineThin = "\n" <> T.concat (P.take 80 $ repeat "-")
+
+    runWarp =
+      runSettings $
+        defaultSettings
+          & setPort port
+          & setOnException
+            ( \_ exception -> do
+                let exceptionText :: Text = show exception
+                if (exceptionText == "Thread killed by timeout manager")
+                  || ( exceptionText
+                        == "Warp: Client closed connection prematurely"
+                     )
+                  then pure ()
+                  else do
+                    putText exceptionText
+            )
+
+    buildBanner
+      :: Text
+      -> Text
+      -> Text
+      -> Text
+      -> Text
+    buildBanner
+      sqliteEmbeddedVersion
+      sqliteBinaryVersion
+      graphiQLVersion
+      baseUrl =
+        separatorLine
+          <> "\n\n"
+          <> "AirGQL Server\n"
+          <> separatorLineThin
+          <> "\n\n"
+          <> "Version:\t\t  "
+          <> versionSlug
+          <> "\n\
+             \GraphQL URL:\t\t  "
+          <> baseUrl
+          <> "/graphql"
+          <> "\n\
+             \\n\
+             \SQLite Embedded version:  "
+          <> sqliteEmbeddedVersion
+          <> "\n\
+             \SQLite Binary version:\t  "
+          <> sqliteBinaryVersion
+          <> "\n\
+             \GraphiQL version:\t  "
+          <> graphiQLVersion
+          <> "\n"
+          <> separatorLine
+          <> "\n"
+
+  providedArgs <-
+    cmdArgs $
+      modes
+        [ cliHelp
+        , cliVersion
+        , cliServe
+        ]
+        &= program "airgql"
+        &= summary (T.unpack versionSlug)
+        &= help "Automatic GraphQL API generation for SQLite databases"
+
+  case providedArgs of
+    Help ->
+      putText "Run `airgql --help` for detailed usage instructions"
+    ----------
+    Version ->
+      putText versionSlug
+    ----------
+    Serve{dbFilePath} -> do
+      SS.withConnection dbFilePath $ \conn -> do
+        P.when (dbFilePath == "") $
+          P.die "ERROR: No database file path was specified"
+
+        let baseUrl :: Text = "http://localhost:" <> show port
+        ctx <- getExternalAppContext baseUrl
+        sqliteEmbeddedVersion <- getSqliteEmbeddedVersion conn
+        sqliteBinaryVersion <- getSqliteBinaryVersion ctx
+        graphiQLVersion <- getGraphiQLVersion
+
+        putText $
+          buildBanner
+            sqliteEmbeddedVersion
+            sqliteBinaryVersion
+            graphiQLVersion
+            baseUrl
+
+        runWarp $ corsMiddleware $ platformApp ctx dbFilePath

makefile

@@ -0,0 +1,12 @@
+.PHONY: test
+test:
+	stack \
+		--stack-yaml stack-standalone.yaml \
+		test
+
+
+.PHONY: install
+install:
+	stack \
+		--stack-yaml stack-standalone.yaml \
+		install

package.yaml

@@ -0,0 +1,143 @@
+name: airgql
+version: 0.7.1.2
+synopsis: Automatically generate a GraphQL API for an SQLite database
+description: |
+  AirGQL automatically generates a GraphQL API for SQLite databases.
+  It analyses the database schema
+  and builds the corresponding GraphQL introspection and data resolvers.
+
+  The generated API supports all basic CRUD operations and
+  even complex queries and mutations including filters and pagination.
+  It's the perferct solution for easily integrating GraphQL support
+  into existing Haskell servers.
+
+  AirGQL is part of the Airsequel project, which provides a complete solution
+  for building web applications on top of SQLite databases.
+homepage: https://github.com/Airsequel/AirGQL
+license: AGPL-3.0-or-later
+author: Feram GmbH
+maintainer: adrian@feram.io
+copyright: 2024 Feram GmbH
+category: Web, Database, SQL, SQLite, GraphQL, Servant, CLI Tool
+
+extra-source-files:
+  - readme.md
+
+flags:
+  lib-only:
+    description: Only build/install the library and not the CLI tool.
+    manual: true
+    default: false
+
+dependencies:
+  - base >= 4.18.2 && < 4.19
+  - protolude >= 0.3.4 && < 0.4
+  - text >= 2.0.2 && < 2.1
+  - sqlite-simple >= 0.4.19 && < 0.5
+
+default-extensions:
+  - DataKinds
+  - DeriveGeneric
+  - DerivingStrategies
+  - DuplicateRecordFields
+  - FlexibleContexts
+  - FlexibleInstances
+  - GADTs
+  - GeneralizedNewtypeDeriving
+  - ImportQualifiedPost
+  - LambdaCase
+  - MultiParamTypeClasses
+  - MultiWayIf
+  - NamedFieldPuns
+  - NoImplicitPrelude
+  - NumericUnderscores
+  - OverloadedRecordDot
+  - OverloadedStrings
+  - RankNTypes
+  - RecordWildCards
+  - ScopedTypeVariables
+  - StandaloneDeriving
+  - TupleSections
+  - TypeApplications
+  - TypeFamilies
+  - TypeOperators
+  - TypeSynonymInstances
+  - UndecidableInstances
+
+ghc-options:
+  - -fno-warn-orphans
+  - -fwrite-ide-info
+  - -Weverything
+  - -Wno-all-missed-specialisations
+  - -Wno-missing-deriving-strategies
+  - -Wno-missing-kind-signatures
+  - -Wno-missing-safe-haskell-mode
+  - -Wno-unsafe
+
+library:
+  source-dirs: source
+  dependencies:
+    - aeson >= 2.1.2.1 && < 2.3
+    - blaze-markup >= 0.8.3 && < 0.9
+    - bytestring >= 0.11.5 && < 0.12
+    - conduit >= 1.3.5 && < 1.4
+    - directory >= 1.3.8 && < 1.4
+    - double-x-encoding >= 1.2.1 && < 1.3
+    - exceptions >= 0.10.7 && < 0.11
+    - extra >= 1.7.14 && < 1.8
+    - filepath >= 1.4.200 && < 1.5
+    - graphql >= 1.2.0.1 && < 1.4
+    - graphql-spice >= 1.0.2 && < 1.1
+    - http-types >= 0.12.4 && < 0.13
+    - process >= 1.6.17 && < 1.7
+    - scientific >= 0.3.7 && < 0.4
+    - servant >= 0.20.1 && < 0.21
+    - servant-blaze >= 0.9.1 && < 0.10
+    - servant-docs >= 0.13 && < 0.14
+    - servant-multipart >= 0.12.1 && < 0.13
+    - servant-server >= 0.20 && < 0.21
+    - simple-sql-parser >= 0.6.1 && < 0.8
+    - template-haskell >= 2.20.0 && < 2.21
+    - time >= 1.12.2 && < 1.13
+    - typed-process >= 0.2.11 && < 0.3
+    - unix >= 2.8.4 && < 2.9
+    - unordered-containers >= 0.2.20 && < 0.3
+    - wai >= 3.2.4 && < 3.3
+    - wai-extra >= 3.1.14 && < 3.2
+
+executables:
+  airgql:
+    when:
+      - condition: flag(lib-only)
+        then: { buildable: false }
+        else: { buildable: true }
+    source-dirs: app
+    main: Main.hs
+    ghc-options:
+      - -threaded
+    dependencies:
+      - airgql
+      - cmdargs >= 0.10.22 && < 0.11
+      - githash >= 0.1.7 && < 0.2
+      - http-client >= 0.7.17 && < 0.8
+      - wai >= 3.2.4 && < 3.3
+      - wai-cors >= 0.2.7 && < 0.3
+      - warp >= 3.3.31 && < 3.4
+
+tests:
+  airgql-test:
+    main: Spec.hs
+    source-dirs: tests
+    dependencies:
+      - aeson >= 2.1.2.1 && < 2.3
+      - airgql
+      - bytestring >= 0.11.5 && < 0.12
+      - directory >= 1.3.8 && < 1.4
+      - exceptions >= 0.10.7 && < 0.11
+      - filepath >= 1.4.200 && < 1.5
+      - graphql >= 1.2.0.1 && < 1.4
+      - graphql-spice >= 1.0.2 && < 1.1
+      - hspec >= 2.11.8 && < 2.12
+      - servant-server >= 0.20 && < 0.21
+      - unix >= 2.8.4 && < 2.9
+      - unordered-containers >= 0.2.20 && < 0.3

readme.md

@@ -0,0 +1,101 @@
+# AirGQL
+
+Automatically generate a GraphQL API for an SQLite database.
+
+<img
+  alt="Diagram of SQL to GraphQL conversion"
+  src="./images/sql_to_graphql.png"
+  style="width: 60%;"
+/>
+
+## How It Works
+
+It analyses the database schema
+and builds the corresponding GraphQL introspection and data resolvers.
+
+The generated API supports all basic CRUD operations and
+even complex queries and mutations including filters and pagination.
+
+It is designed to be either used a Haskell library
+for integrating GraphQL support into existing servers
+or as a standalone CLI app for quickly spinning up a backend.
+
+AirGQL is the core component of [Airsequel](https://www.airsequel.com/),
+which provides a complete solution for building web applications
+on top of SQLite databases.
+
+
+## Installation
+
+### CLI Tool
+
+You can install the CLI app using
+[Stack](https://docs.haskellstack.org/en/stable/):
+
+```sh
+git clone https://github.com/Airsequel/AirGQL
+cd AirGQL
+make install
+```
+
+
+### Library
+
+You can also use AirGQL in your Haskell project
+by adding the [Hackage package](https://hackage.haskell.org/package/airgql)
+as a dependency to your `package.yaml` or your `*.cabal` file:
+
+```yaml
+dependencies:
+  - airgql
+  - …
+```
+
+
+## Usage
+
+### CLI App
+
+Run following command to start a GraphQL API server
+for an existing SQLite database:
+
+```sh
+stack run -- serve tests/example.sqlite
+```
+
+Then you can query the API like this:
+
+```sh
+http POST http://localhost:4189/graphql \
+  query='query {
+    songs(limit: 2) {
+      id
+      title
+    }
+  }'
+```
+
+It also supports mutations:
+
+```sh
+http POST http://localhost:4189/graphql \
+  query='mutation {
+    insert_songs(objects: [{ title: "New Song" }]) {
+      returning {
+        id
+        title
+      }
+    }
+  }'
+```
+
+Check out the documentation at
+[docs.airsequel.com/graphql-api](https://docs.airsequel.com/graphql-api)
+for more details on how to use all of its GraphQL features.
+
+
+### Library
+
+Check out the code in [app/Main.hs](./app/Main.hs) file for an example
+of how to build a simple [Servant](https://www.servant.dev/) server
+leveraging AirGQL.

source/AirGQL/Config.hs

@@ -0,0 +1,42 @@
+module AirGQL.Config (
+  Config (..),
+  maxGraphqlResultCount,
+  defaultConfig,
+)
+where
+
+import Data.Bool (Bool (False))
+import Data.Int (Int)
+
+
+-- | The maximum number of results allowed for the GraphiQL playground
+maxGraphqlResultCount :: Int
+maxGraphqlResultCount = 10000
+
+
+data Config = Config
+  { maxTablesPerDb :: Int
+  , maxColumnsPerTable :: Int
+  , maxRowsPerTable :: Int
+  , maxVisibleCellsPerTable :: Int
+  , maxDbSize :: Int -- Bytes
+  , maxCellSize :: Int -- Bytes
+  , hardHeapLimit :: Int -- Bytes
+  , sqlTimeoutTime :: Int -- Seconds
+  , allowRecursiveTriggers :: Bool
+  }
+
+
+defaultConfig :: Config
+defaultConfig =
+  Config
+    { maxTablesPerDb = 100
+    , maxColumnsPerTable = 500
+    , maxRowsPerTable = 100_000
+    , maxVisibleCellsPerTable = 0 -- Not used currently
+    , maxDbSize = 100_000_000 -- Bytes
+    , maxCellSize = 10_000_000 -- Bytes
+    , hardHeapLimit = 500_000_000 -- Bytes
+    , sqlTimeoutTime = 20
+    , allowRecursiveTriggers = False
+    }

source/AirGQL/ExternalAppContext.hs

@@ -0,0 +1,75 @@
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Use maybe" #-}
+module AirGQL.ExternalAppContext (
+  SandboxingConfig (..),
+  ExternalAppContext (..),
+  getExternalAppContext,
+) where
+
+import Protolude (
+  FilePath,
+  IO,
+  Maybe (Just, Nothing),
+  Show,
+  Text,
+  not,
+  pure,
+  ($),
+  (&&),
+  (/=),
+  (<|>),
+  (==),
+ )
+import Protolude qualified as P
+
+import Data.ByteString qualified as BS
+import Data.Text qualified as T
+import System.Environment (lookupEnv)
+import System.Info (os)
+import System.Process.Typed (ExitCode (ExitSuccess), proc, readProcessStdout)
+
+
+lookupBinaryPath :: Text -> IO (Maybe FilePath)
+lookupBinaryPath name = do
+  (code, resultBS) <- readProcessStdout $ proc "which" [T.unpack name]
+  let result = T.strip $ P.decodeUtf8 $ BS.toStrict resultBS
+  pure $
+    if code == ExitSuccess
+      && result /= ""
+      && not ("which: no" `T.isInfixOf` result)
+      then Just $ T.unpack result
+      else Nothing
+
+
+data SandboxingConfig = SandboxingConfig
+  { firejail :: FilePath
+  , extraBinds :: [FilePath]
+  }
+  deriving (Show)
+
+
+data ExternalAppContext = ExternalAppContext
+  { sqlite :: FilePath
+  , sqliteLib :: Maybe FilePath
+  , baseUrl :: Text
+  }
+  deriving (Show)
+
+
+getExternalAppContext :: Text -> IO ExternalAppContext
+getExternalAppContext baseUrl = do
+  sqlite <- lookupBinaryPath "sqlite3"
+  sqliteEnv <- lookupEnv "AIRGQL_SQLITE_BIN"
+  sqliteLib <- lookupEnv "AIRGQL_SQLITE_LIB"
+
+  pure $
+    ExternalAppContext
+      { baseUrl = baseUrl
+      , sqlite = P.fromMaybe "/usr/bin/sqlite3" $ sqliteEnv <|> sqlite
+      , sqliteLib =
+          sqliteLib
+            <|> if os == "darwin"
+              then Just "/usr/local/opt/sqlite/lib/libsqlite3.dylib"
+              else Nothing
+      }

source/AirGQL/GQLWrapper.hs

@@ -0,0 +1,47 @@
+{-|
+Increase readability of code
+by wrapping `graphql` library with descriptive wrappers
+-}
+module AirGQL.GQLWrapper (
+  OutField (..),
+  outFieldToField,
+  InArgument (..),
+  inArgumentToArgument,
+)
+where
+
+import Protolude (Maybe, Text)
+
+import Language.GraphQL.Type (Value)
+import Language.GraphQL.Type.In qualified as In
+import Language.GraphQL.Type.Out qualified as Out
+
+
+data OutField m = OutField
+  { descriptionMb :: Maybe Text
+  , fieldType :: Out.Type m
+  , arguments :: In.Arguments
+  }
+
+
+outFieldToField :: OutField m -> Out.Field m
+outFieldToField outField =
+  Out.Field
+    outField.descriptionMb
+    outField.fieldType
+    outField.arguments
+
+
+data InArgument = InArgument
+  { argDescMb :: Maybe Text
+  , argType :: In.Type
+  , valueMb :: Maybe Value
+  }
+
+
+inArgumentToArgument :: InArgument -> In.Argument
+inArgumentToArgument inArgument =
+  In.Argument
+    inArgument.argDescMb
+    inArgument.argType
+    inArgument.valueMb

source/AirGQL/Raw.hs

@@ -0,0 +1,30 @@
+{-# OPTIONS_GHC -Wno-deprecations #-}
+
+module AirGQL.Raw (raw) where
+
+import Protolude (pure, (.))
+import Protolude.Error (error)
+
+import Language.Haskell.TH (Exp (LitE), Lit (StringL))
+import Language.Haskell.TH.Quote (
+  QuasiQuoter (QuasiQuoter, quoteDec, quoteExp, quotePat, quoteType),
+ )
+
+
+raw :: QuasiQuoter
+raw =
+  QuasiQuoter
+    { quoteExp = pure . LitE . StringL
+    , quotePat = \_ ->
+        error
+          "Illegal raw string QuasiQuote \
+          \(allowed as expression only, used as a pattern)"
+    , quoteType = \_ ->
+        error
+          "Illegal raw string QuasiQuote \
+          \(allowed as expression only, used as a type)"
+    , quoteDec = \_ ->
+        error
+          "Illegal raw string QuasiQuote \
+          \(allowed as expression only, used as a declaration)"
+    }

source/AirGQL/Servant/Database.hs

@@ -0,0 +1,46 @@
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Use maybe" #-}
+{-# HLINT ignore "Avoid lambda" #-}
+{-# HLINT ignore "Replace case with maybe" #-}
+
+module AirGQL.Servant.Database (
+  apiDatabaseSchemaGetHandler,
+  apiDatabaseVacuumPostHandler,
+) where
+
+import Protolude (
+  Applicative (pure),
+  MonadIO (liftIO),
+  Monoid (mempty),
+  ($),
+ )
+
+import Data.Aeson (Object)
+import Data.Text (Text)
+import Database.SQLite.Simple qualified as SS
+import Servant.Server qualified as Servant
+
+import AirGQL.ExternalAppContext (ExternalAppContext)
+import AirGQL.Utils (
+  getMainDbPath,
+  runSqliteCommand,
+  withRetryConn,
+ )
+
+
+apiDatabaseSchemaGetHandler
+  :: ExternalAppContext
+  -> Text
+  -> Servant.Handler Text
+apiDatabaseSchemaGetHandler ctx dbId = do
+  runSqliteCommand ctx (getMainDbPath dbId) ".schema"
+
+
+apiDatabaseVacuumPostHandler
+  :: Text
+  -> Servant.Handler Object
+apiDatabaseVacuumPostHandler dbId = do
+  liftIO $ withRetryConn (getMainDbPath dbId) $ \conn ->
+    SS.execute_ conn "VACUUM"
+  pure mempty

source/AirGQL/Servant/GraphQL.hs

@@ -0,0 +1,149 @@
+module AirGQL.Servant.GraphQL (
+  gqlQueryGetHandler,
+  gqlQueryPostHandler,
+  playgroundDefaultQueryHandler,
+  readOnlyGqlPostHandler,
+  writeOnlyGqlPostHandler,
+) where
+
+import Protolude (
+  Applicative (pure),
+  MonadIO (liftIO),
+  Monoid (mempty),
+  Semigroup ((<>)),
+  ($),
+  (&),
+ )
+import Protolude qualified as P
+
+import Control.Monad.Catch (catchAll)
+import Data.Aeson (Object)
+import Data.Text (Text)
+import Data.Text qualified as T
+import DoubleXEncoding (doubleXEncodeGql)
+import Servant (NoContent, err303, errHeaders)
+import Servant.Server qualified as Servant
+import System.Directory (makeAbsolute)
+
+import AirGQL.Lib (
+  AccessMode (ReadOnly, WriteOnly),
+  column_name,
+  getColumns,
+  getTableNames,
+ )
+import AirGQL.ServerUtils (executeQuery)
+import AirGQL.Types.SchemaConf (SchemaConf (accessMode), defaultSchemaConf)
+import AirGQL.Types.Types (GQLPost (operationName, query, variables))
+import AirGQL.Utils (
+  getDbDir,
+  getMainDbPath,
+  getReadOnlyFilePath,
+  throwErr400WithMsg,
+  throwErr404WithMsg,
+  withRetryConn,
+ )
+import System.FilePath (pathSeparator, takeDirectory)
+
+
+gqlQueryGetHandler :: Text -> Servant.Handler NoContent
+gqlQueryGetHandler dbId =
+  P.throwError
+    err303
+      { errHeaders =
+          [("Location", P.encodeUtf8 $ "/dbs/" <> dbId <> "/graphiql")]
+      }
+
+
+gqlQueryPostHandler
+  :: SchemaConf
+  -> Text
+  -> GQLPost
+  -> Servant.Handler Object
+gqlQueryPostHandler schemaConf dbIdOrPath gqlPost = do
+  let
+    handleNoDbError :: P.SomeException -> Servant.Handler a
+    handleNoDbError excpetion = do
+      let errMsg = P.show excpetion
+
+      if "unable to open database file" `T.isInfixOf` errMsg
+        then
+          throwErr404WithMsg $
+            "Database \"" <> dbIdOrPath <> "\" does not exist"
+        else do
+          P.putErrLn $
+            "Error during execution of GraphQL query: " <> errMsg
+          throwErr400WithMsg errMsg
+
+  catchAll
+    ( liftIO $ do
+        reqDir <-
+          if pathSeparator `T.elem` dbIdOrPath
+            then pure $ takeDirectory $ T.unpack dbIdOrPath
+            else makeAbsolute $ getDbDir dbIdOrPath
+
+        executeQuery
+          schemaConf
+          dbIdOrPath
+          reqDir
+          gqlPost.query
+          (gqlPost.variables & P.fromMaybe mempty)
+          gqlPost.operationName
+    )
+    handleNoDbError
+
+
+readOnlyGqlPostHandler :: Text -> GQLPost -> Servant.Handler Object
+readOnlyGqlPostHandler dbIdOrPath gqlPost =
+  liftIO $ do
+    reqDir <- makeAbsolute $ getReadOnlyFilePath dbIdOrPath
+
+    executeQuery
+      defaultSchemaConf{accessMode = ReadOnly}
+      dbIdOrPath
+      reqDir
+      gqlPost.query
+      (gqlPost.variables & P.fromMaybe mempty)
+      gqlPost.operationName
+
+
+writeOnlyGqlPostHandler :: Text -> GQLPost -> Servant.Handler Object
+writeOnlyGqlPostHandler dbPath gqlPost =
+  liftIO $ do
+    reqDir <- makeAbsolute $ getReadOnlyFilePath dbPath
+
+    executeQuery
+      defaultSchemaConf{accessMode = WriteOnly}
+      dbPath
+      reqDir
+      gqlPost.query
+      (gqlPost.variables & P.fromMaybe mempty)
+      gqlPost.operationName
+
+
+playgroundDefaultQueryHandler
+  :: Text
+  -> Servant.Handler Text
+playgroundDefaultQueryHandler dbId = do
+  liftIO $ withRetryConn (getMainDbPath dbId) $ \mainConn -> do
+    tableEntries <- getTableNames mainConn
+
+    case tableEntries of
+      (headTable : _) -> do
+        cols <- getColumns dbId mainConn headTable
+        pure $
+          P.fold
+            [ "query "
+            , doubleXEncodeGql headTable
+            , "Query {\n"
+            , "  "
+            , doubleXEncodeGql headTable
+            , "( limit: 100 ) {\n"
+            , cols
+                & P.foldMap
+                  ( \col ->
+                      "    " <> doubleXEncodeGql col.column_name <> "\n"
+                  )
+            , "  }\n"
+            , "}"
+            ]
+      _ -> pure ""

source/AirGQL/Servant/SqlQuery.hs

@@ -0,0 +1,198 @@
+module AirGQL.Servant.SqlQuery (
+  getAffectedTables,
+  sqlQueryPostHandler,
+)
+where
+
+import Protolude (
+  Applicative (pure),
+  Either (Left, Right),
+  Maybe (Just, Nothing),
+  MonadIO (liftIO),
+  Semigroup ((<>)),
+  otherwise,
+  show,
+  when,
+  ($),
+  (&),
+  (*),
+  (-),
+  (/=),
+  (<&>),
+  (>),
+ )
+import Protolude qualified as P
+
+import Data.Aeson.Key qualified as Key
+import Data.Aeson.KeyMap qualified as KeyMap
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Time (diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds)
+import Database.SQLite.Simple qualified as SS
+import Language.SQL.SimpleSQL.Parse (ParseError (peFormattedError))
+import Language.SQL.SimpleSQL.Syntax (Statement (CreateTable))
+import Servant.Server qualified as Servant
+import System.Timeout (timeout)
+
+import AirGQL.Config (defaultConfig, sqlTimeoutTime)
+import AirGQL.Lib (
+  SQLPost (query),
+  TableEntryRaw (sql, tbl_name),
+  getTables,
+  lintTableCreationCode,
+  parseSql,
+  sqlDataToAesonValue,
+ )
+import AirGQL.Types.PragmaConf (PragmaConf, getSQLitePragmas)
+import AirGQL.Types.SqlQueryPostResult (
+  SqlQueryPostResult (
+    SqlQueryPostResult,
+    affectedTables,
+    columns,
+    errors,
+    rows,
+    runtimeSeconds
+  ),
+  resultWithErrors,
+ )
+import AirGQL.Utils (
+  getMainDbPath,
+  throwErr400WithMsg,
+  withRetryConn,
+ )
+
+
+getAffectedTables :: [TableEntryRaw] -> [TableEntryRaw] -> [Text]
+getAffectedTables pre post =
+  let
+    loop left right = do
+      case (left, right) of
+        ([], _) -> right <&> tbl_name
+        (_, []) -> left <&> tbl_name
+        (headLeft : tailLeft, headRight : tailRight) ->
+          case P.compare headLeft.tbl_name headRight.tbl_name of
+            P.LT -> headLeft.tbl_name : loop tailLeft right
+            P.GT -> headRight.tbl_name : loop left tailRight
+            P.EQ
+              | headLeft.sql /= headRight.sql ->
+                  headLeft.tbl_name : loop tailLeft tailRight
+              | otherwise ->
+                  loop tailLeft tailRight
+  in
+    loop
+      (P.sortOn tbl_name pre)
+      (P.sortOn tbl_name post)
+
+
+sqlQueryPostHandler
+  :: PragmaConf
+  -> Text
+  -> SQLPost
+  -> Servant.Handler SqlQueryPostResult
+sqlQueryPostHandler pragmaConf dbId sqlPost = do
+  let maxSqlQueryLength :: P.Int = 100_000
+
+  when (T.length sqlPost.query > maxSqlQueryLength) $ do
+    throwErr400WithMsg $
+      "SQL query is too long ("
+        <> show (T.length sqlPost.query)
+        <> " characters, maximum is "
+        <> show maxSqlQueryLength
+        <> ")"
+
+  validationErrors <- liftIO $ case parseSql sqlPost.query of
+    Left error -> pure [T.pack error.peFormattedError]
+    Right statement@(CreateTable _ _) ->
+      SS.withConnection (getMainDbPath dbId) $ \conn ->
+        lintTableCreationCode (Just conn) statement
+    _ -> pure []
+
+  case validationErrors of
+    [] -> do
+      let
+        dbFilePath = getMainDbPath dbId
+        microsecondsPerSecond = 1000000 :: P.Int
+
+        timeoutTimeMicroseconds =
+          defaultConfig.sqlTimeoutTime
+            * microsecondsPerSecond
+
+      sqlitePragmas <- liftIO $ getSQLitePragmas pragmaConf
+
+      let
+        performSqlOperations =
+          withRetryConn dbFilePath $ \conn -> do
+            preTables <- getTables conn
+
+            P.for_ sqlitePragmas $ SS.execute_ conn
+            SS.execute_ conn "PRAGMA foreign_keys = True"
+
+            let query = SS.Query sqlPost.query
+
+            columnNames <- SS.withStatement conn query $ \statement -> do
+              numCols <- SS.columnCount statement
+              P.for [0 .. (numCols - 1)] $ SS.columnName statement
+
+            tableRowsMb :: Maybe [[SS.SQLData]] <-
+              timeout timeoutTimeMicroseconds $ SS.query_ conn query
+            changes <- SS.changes conn
+
+            postTables <- getTables conn
+
+            pure $ case tableRowsMb of
+              Just tableRows ->
+                Right (columnNames, tableRows, changes, preTables, postTables)
+              Nothing -> Left "Sql query execution timed out"
+
+      startTime <- liftIO getCurrentTime
+      sqlResults <-
+        liftIO $
+          P.catches
+            performSqlOperations
+            [ P.Handler $
+                \(error :: SS.SQLError) -> pure $ Left $ show error
+            , P.Handler $
+                \(error :: SS.ResultError) -> pure $ Left $ show error
+            , P.Handler $
+                \(error :: SS.FormatError) -> pure $ Left $ show error
+            ]
+      endTime <- liftIO getCurrentTime
+
+      let measuredTime =
+            nominalDiffTimeToSeconds
+              (diffUTCTime endTime startTime)
+
+      case sqlResults of
+        Left error ->
+          pure $ resultWithErrors measuredTime [error]
+        Right (columnNames, tableRows, changes, preTables, postTables) -> do
+          -- TODO: Use GQL error format {"message": "…", "code": …, …} instead
+          let
+            keys = columnNames <&> Key.fromText
+
+            rowList =
+              tableRows
+                <&> \row ->
+                  row
+                    <&> sqlDataToAesonValue ""
+                    & P.zip keys
+                    & KeyMap.fromList
+
+            affectedTables =
+              if changes > 0
+                then postTables <&> tbl_name
+                else getAffectedTables preTables postTables
+
+          pure $
+            SqlQueryPostResult
+              { rows = rowList
+              , columns = columnNames
+              , runtimeSeconds = measuredTime
+              , affectedTables = affectedTables
+              , errors = []
+              }
+    _ ->
+      pure $
+        resultWithErrors
+          0
+          validationErrors

source/AirGQL/ServerUtils.hs

@@ -0,0 +1,71 @@
+module AirGQL.ServerUtils (
+  executeQuery,
+) where
+
+import Protolude (
+  Applicative (pure),
+  Either (Left, Right),
+  FilePath,
+  IO,
+  Maybe (Just, Nothing),
+  toList,
+  ($),
+  (&),
+  (<&>),
+ )
+import Protolude qualified as P
+
+import Conduit (sourceToList)
+import Control.Arrow ((>>>))
+import Data.Aeson (Object, Value (String))
+import Data.Text (Text)
+import Data.Text qualified as T
+import Database.SQLite.Simple qualified as SS
+import Language.GraphQL.Error (Error (Error), Response (Response))
+import Language.GraphQL.JSON (graphql)
+import System.FilePath (pathSeparator, (</>))
+
+import AirGQL.GraphQL (getDerivedSchema)
+import AirGQL.Lib (getTables)
+import AirGQL.Types.SchemaConf (SchemaConf)
+import AirGQL.Types.Types (
+  GQLResponse (GQLResponse, data_, errors),
+  gqlResponseToObject,
+ )
+
+
+executeQuery
+  :: SchemaConf
+  -> Text
+  -> FilePath
+  -> Text
+  -> Object
+  -> Maybe Text
+  -> IO Object
+executeQuery schemaConf dbIdOrPath reqDir query vars opNameMb = do
+  let dbFilePath =
+        if pathSeparator `T.elem` dbIdOrPath
+          then T.unpack dbIdOrPath
+          else reqDir </> "main.sqlite"
+
+  theConn <- SS.open dbFilePath
+  tables <- getTables theConn
+  schema <- getDerivedSchema schemaConf theConn dbIdOrPath tables
+  result <- graphql schema opNameMb vars query
+  SS.close theConn
+
+  case result of
+    Left errMsg -> do
+      errors <- sourceToList errMsg
+      pure $
+        gqlResponseToObject $
+          GQLResponse
+            { data_ = Nothing
+            , errors =
+                Just $
+                  errors
+                    <&> ((\(Response _ errs) -> errs) >>> toList)
+                    & P.concat
+                    <&> (\(Error msg _ _) -> String msg)
+            }
+    Right response -> pure response

source/AirGQL/Types/OutObjectType.hs

@@ -0,0 +1,28 @@
+module AirGQL.Types.OutObjectType (
+  OutObjectType (OutObjectType, name, descriptionMb, interfaceTypes, fields),
+  outObjectTypeToObjectType,
+)
+where
+
+import Protolude (Maybe, Text, (&))
+
+import Data.HashMap.Strict (HashMap)
+import Language.GraphQL.Type (InterfaceType)
+import Language.GraphQL.Type.Out qualified as Out
+
+
+data OutObjectType m = OutObjectType
+  { name :: Text
+  , descriptionMb :: Maybe Text
+  , interfaceTypes :: [InterfaceType m]
+  , fields :: HashMap Text (Out.Resolver m)
+  }
+
+
+outObjectTypeToObjectType :: OutObjectType m -> Out.ObjectType m
+outObjectTypeToObjectType objectType =
+  Out.ObjectType
+    (objectType & name)
+    (objectType & (descriptionMb :: OutObjectType m -> Maybe Text))
+    (objectType & interfaceTypes)
+    (objectType & fields)

source/AirGQL/Types/PragmaConf.hs

@@ -0,0 +1,56 @@
+module AirGQL.Types.PragmaConf (
+  PragmaConf (..),
+  getSQLitePragmas,
+  defaultConf,
+)
+where
+
+import Protolude (
+  Bool (True),
+  IO,
+  Int,
+  Integer,
+  pure,
+  show,
+  ($),
+  (<>),
+ )
+
+import Database.SQLite.Simple qualified as SS
+
+
+data PragmaConf = PragmaConf
+  { maxPageCount :: Int
+  , hardHeapLimit :: Integer
+  , allowRecursTrig :: Bool
+  }
+
+
+defaultConf :: PragmaConf
+defaultConf =
+  PragmaConf
+    { maxPageCount = 4096
+    , hardHeapLimit = 500_000_000 -- Bytes
+    , allowRecursTrig = True
+    }
+
+
+-- | Get the SQLite pragmas to use for a database
+getSQLitePragmas :: PragmaConf -> IO [SS.Query]
+getSQLitePragmas pragConf = do
+  let
+    getPrag key value =
+      SS.Query $ "PRAGMA " <> key <> " = " <> value
+
+  pure
+    [ getPrag "case_sensitive_like" "True"
+    , getPrag "foreign_keys" "True"
+    , -- TODO: Check if this really works
+      getPrag "hard_heap_limit" $ show @Integer pragConf.hardHeapLimit
+    , getPrag "max_page_count" $ show @Int pragConf.maxPageCount
+    , getPrag "recursive_triggers" $ show @Bool pragConf.allowRecursTrig
+    , -- TODO: Reactivate after https://sqlite.org/forum/forumpost/d7b9a365e0
+      --       (Also activate in SqlQuery.hs)
+      -- , getPrag "trusted_schema" "False"
+      getPrag "writable_schema" "False"
+    ]

source/AirGQL/Types/SchemaConf.hs

@@ -0,0 +1,26 @@
+module AirGQL.Types.SchemaConf (
+  SchemaConf (..),
+  defaultSchemaConf,
+) where
+
+import Protolude (Integer)
+
+import AirGQL.Lib (AccessMode (ReadAndWrite))
+import AirGQL.Types.PragmaConf (PragmaConf, defaultConf)
+
+
+data SchemaConf = SchemaConf
+  { accessMode :: AccessMode
+  , pragmaConf :: PragmaConf
+  , maxRowsPerTable :: Integer
+  }
+
+
+-- | Default schema configuration
+defaultSchemaConf :: SchemaConf
+defaultSchemaConf =
+  SchemaConf
+    { accessMode = ReadAndWrite
+    , pragmaConf = AirGQL.Types.PragmaConf.defaultConf
+    , maxRowsPerTable = 100_000
+    }

source/AirGQL/Types/SqlQueryPostResult.hs

@@ -0,0 +1,107 @@
+module AirGQL.Types.SqlQueryPostResult (
+  SqlQueryPostResult (..),
+  resultWithErrors,
+)
+where
+
+import Protolude (
+  Generic,
+  Show,
+  Text,
+  foldMap,
+  fromMaybe,
+  ($),
+  (&),
+  (<>),
+ )
+
+import Control.Arrow ((>>>))
+import Data.Aeson (
+  FromJSON,
+  Object,
+  ToJSON,
+  Value (Null, Number),
+ )
+import Data.Aeson.Encoding (list, pair, pairs)
+import Data.Aeson.Key qualified as Key
+import Data.Aeson.KeyMap qualified as KeyMap
+import Data.Aeson.Types (toEncoding, (.=))
+import Data.Fixed (Pico)
+import Servant.Docs (ToSample (toSamples), singleSample)
+
+
+data SqlQueryPostResult = SqlQueryPostResult
+  { affectedTables :: [Text]
+  , rows :: [Object]
+  , columns :: [Text] -- Only necessary for order of columns in the result
+  , runtimeSeconds :: Pico -- Precision contained by `NominalDiffTime`
+  , errors :: [Text]
+  }
+  deriving (Show, Generic)
+
+
+instance FromJSON SqlQueryPostResult
+
+
+{-| Even though JSON objects are unordered by definition,
+the fields (columns) must be returned in the requested order
+as Elm relies on it for decoding.
+-}
+instance ToJSON SqlQueryPostResult where
+  toEncoding sqlQueryPostResult =
+    pairs $
+      "affectedTables" .= sqlQueryPostResult.affectedTables
+        <> "rows"
+          `pair` ( sqlQueryPostResult.rows
+                    & list
+                      ( \(row :: Object) ->
+                          -- Apply order of columns
+                          sqlQueryPostResult.columns
+                            & foldMap
+                              ( Key.fromText
+                                  >>> ( \col ->
+                                          col
+                                            .= ( row
+                                                  & KeyMap.lookup col
+                                                  & fromMaybe Null
+                                               )
+                                      )
+                              )
+                            & pairs
+                      )
+                 )
+        <> "runtimeSeconds" .= sqlQueryPostResult.runtimeSeconds
+        <> "errors" .= sqlQueryPostResult.errors
+
+
+instance ToSample SqlQueryPostResult where
+  toSamples _ =
+    singleSample $
+      SqlQueryPostResult
+        { affectedTables = ["users"]
+        , rows =
+            [ KeyMap.fromList
+                [ (Key.fromText "id", Number 1)
+                , (Key.fromText "name", "John")
+                ]
+            , KeyMap.fromList
+                [ (Key.fromText "id", Number 2)
+                , (Key.fromText "name", "Jane")
+                ]
+            ]
+        , columns = ["id", "name"]
+        , runtimeSeconds = 0.05
+        , errors = []
+        }
+
+
+-- | Construct a result for a failed sql query execution.
+resultWithErrors :: Pico -> [Text] -> SqlQueryPostResult
+resultWithErrors runtimeSeconds errors =
+  SqlQueryPostResult
+    { affectedTables = []
+    , rows = []
+    , columns = []
+    , runtimeSeconds = runtimeSeconds
+    , errors = errors
+    }

source/AirGQL/Types/TextNullable.hs

@@ -0,0 +1,31 @@
+module AirGQL.Types.TextNullable (
+  TextNullable (..),
+)
+where
+
+import Protolude (
+  Eq,
+  Generic,
+  Show,
+  Text,
+  pure,
+  ($),
+ )
+
+import Data.Aeson (
+  FromJSON,
+  ToJSON,
+  Value (Null, String),
+  parseJSON,
+ )
+
+
+data TextNullable = TextUndefined | TextNull | TextValue Text
+  deriving (Show, Eq, Generic)
+
+
+instance FromJSON TextNullable where
+  parseJSON (String str) = pure $ TextValue str
+  parseJSON Null = pure TextNull
+  parseJSON _ = pure TextUndefined
+instance ToJSON TextNullable

source/AirGQL/Types/Types.hs

@@ -0,0 +1,135 @@
+module AirGQL.Types.Types (
+  FileFormat (..),
+  FilenameField (..),
+  GQLPost (..),
+  GQLResponse (..),
+  gqlResponseToObject,
+  MetadataPair (..),
+  RawJsonMime,
+  Database (..),
+  UsageError (..),
+)
+where
+
+import Protolude (
+  Eq,
+  Generic,
+  Maybe (Nothing),
+  Monoid (mempty),
+  Show,
+  Text,
+ )
+import Protolude qualified as P
+
+import Data.Aeson (
+  FromJSON,
+  KeyValue ((.=)),
+  Object,
+  ToJSON (toJSON),
+  Value (Object),
+  object,
+ )
+import Database.SQLite.Simple qualified as SS
+import Servant.Docs (ToSample (toSamples), singleSample)
+
+
+-- Necessary to avoid JSON string quoting
+data RawJsonMime
+
+
+data FileFormat
+  = SQLiteFile
+  | CSVFile
+  | PlainTextFile
+  | DisallowedFile Text
+  deriving (Show, Eq)
+
+
+data GQLPost = GQLPost
+  { query :: Text
+  , operationName :: Maybe Text
+  , variables :: Maybe Object
+  }
+  deriving (Eq, Show, Generic)
+
+
+instance ToJSON GQLPost
+instance FromJSON GQLPost
+
+
+instance ToSample GQLPost where
+  toSamples _ =
+    singleSample
+      GQLPost
+        { query = "{ users { name, email } }"
+        , variables = Nothing
+        , operationName = Nothing
+        }
+
+
+data GQLResponse = GQLResponse
+  { data_ :: Maybe Value
+  , errors :: Maybe [Value]
+  }
+  deriving (Eq, Show, Generic)
+
+
+instance ToJSON GQLResponse where
+  toJSON GQLResponse{data_, errors} =
+    object
+      [ "data" .= data_
+      , "errors" .= errors
+      ]
+
+
+-- emptyGQLResponse :: GQLResponse
+-- emptyGQLResponse = GQLResponse
+--   { data_ = Nothing
+--   , errors = Nothing
+--   }
+
+newtype FilenameField = FilenameField Text
+  deriving (Generic, Show)
+
+
+instance SS.FromRow FilenameField
+
+
+data MetadataPair = MetadataPair
+  { attribute :: Text
+  , value :: Text
+  }
+  deriving (Eq, Show, Generic)
+
+
+instance SS.FromRow MetadataPair
+
+
+gqlResponseToObject :: GQLResponse -> Object
+gqlResponseToObject gqlRes =
+  case toJSON gqlRes of
+    Object obj -> obj
+    _ -> mempty
+
+
+data Database = Database
+  { id :: Text
+  , name :: Text
+  , environment :: Maybe Text
+  , ownership_utc :: Text
+  }
+  deriving (Generic, Show)
+
+
+instance FromJSON Database
+instance ToJSON Database
+instance SS.FromRow Database
+
+
+-- Errors
+
+newtype UsageError = UsageError Text
+  deriving (Eq, Show)
+
+
+instance P.Exception UsageError

source/AirGQL/Types/Utils.hs

@@ -0,0 +1,14 @@
+module AirGQL.Types.Utils (
+  encodeToText,
+)
+where
+
+import Data.Aeson (ToJSON, encode)
+import Data.ByteString.Lazy (toStrict)
+import Data.Text.Encoding (decodeUtf8)
+import Protolude (Text, (.))
+
+
+encodeToText :: (ToJSON a) => a -> Text
+encodeToText =
+  decodeUtf8 . toStrict . encode

source/AirGQL/Utils.hs

@@ -0,0 +1,361 @@
+-- For embedded SQL queries
+{-# LANGUAGE QuasiQuotes #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Use maybe" #-}
+-- HLint can't figure out where TemplateHaskell is used,
+-- even though it throws an error without the pragma.
+{-# HLINT ignore "Unused LANGUAGE pragma" #-}
+
+module AirGQL.Utils (
+  collectAllErrorsAsText,
+  collectErrorList,
+  colToFileUrl,
+  escDoubleQuotes,
+  escSingleQuotes,
+  getDbDir,
+  getGraphiQLVersion,
+  getMainDbPath,
+  getOrderOfLinkedList,
+  getReadOnlyFilePath,
+  getDbIdFromReadOnlyId,
+  getSqliteBinaryVersion,
+  getSqliteEmbeddedVersion,
+  headerJsonContent,
+  quoteKeyword,
+  quoteText,
+  removeIfExists,
+  runSqliteCommand,
+  throwErr400WithMsg,
+  throwErr404WithMsg,
+  throwErr500WithMsg,
+  withRetryConn,
+  DiffKind (..),
+) where
+
+import Protolude (
+  Applicative (pure),
+  ExitCode (ExitFailure, ExitSuccess),
+  FilePath,
+  IO,
+  Maybe (Just, Nothing),
+  Monoid (mempty),
+  Semigroup ((<>)),
+  Text,
+  catch,
+  liftIO,
+  not,
+  show,
+  throwError,
+  throwIO,
+  when,
+  ($),
+  (&),
+  (.),
+  (/=),
+  (<&>),
+ )
+import Protolude qualified as P
+
+import Control.Monad.Catch (catchAll)
+import Data.Aeson (KeyValue ((.=)), Value (String), encode, object)
+import Data.ByteString qualified as BS
+import Data.ByteString.Builder (toLazyByteString)
+import Data.ByteString.Lazy qualified as BL
+import Data.Either.Extra (mapLeft)
+import Data.List qualified as List
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as T
+import Database.SQLite.Simple (Connection)
+import Database.SQLite.Simple qualified as SS
+import Network.HTTP.Types (HeaderName, encodePathSegments)
+import Servant.Server (
+  ServerError (errBody, errHeaders),
+  err400,
+  err404,
+  err500,
+ )
+import Servant.Server qualified as Servant
+import System.Directory (removeFile)
+import System.FilePath (takeFileName, (</>))
+import System.IO.Error (IOError, isDoesNotExistError)
+import System.Posix.Files (readSymbolicLink)
+import System.Process (readProcess)
+import System.Process.Typed (
+  byteStringInput,
+  createPipe,
+  proc,
+  readProcessInterleaved,
+  setStderr,
+  setStdin,
+  setStdout,
+ )
+
+import AirGQL.ExternalAppContext (ExternalAppContext (sqlite))
+
+
+getDbDir :: Text -> FilePath
+getDbDir dbId =
+  "data"
+    </> "databases"
+    </> T.unpack dbId
+
+
+getMainDbPath :: Text -> FilePath
+getMainDbPath dbId =
+  getDbDir dbId
+    </> "main.sqlite"
+
+
+getReadOnlyFilePath :: Text -> FilePath
+getReadOnlyFilePath readonlyId =
+  "data" </> "readonly" </> T.unpack readonlyId
+
+
+getSqliteEmbeddedVersion :: Connection -> IO Text
+getSqliteEmbeddedVersion conn = do
+  sqliteEmbeddedVersion <-
+    SS.query_
+      conn
+      "select sqlite_version()"
+      :: IO [[SS.SQLData]]
+  case sqliteEmbeddedVersion of
+    [[SS.SQLText verTxt]] -> pure verTxt
+    _ -> pure mempty
+
+
+getSqliteBinaryVersion :: ExternalAppContext -> IO Text
+getSqliteBinaryVersion ctx = do
+  P.fmap (T.strip . T.pack) $
+    readProcess
+      ctx.sqlite
+      ["--safe", ":memory:"]
+      (T.unpack "select sqlite_version()")
+
+
+getGraphiQLVersion :: IO Text
+getGraphiQLVersion = do
+  -- let packageJson :: BL.ByteString =
+  --       $( "package.json"
+  --           & makeRelativeToProject
+  --           P.>>= embedStringFile
+  --        )
+  --
+  -- pure $
+  --   (Aeson.decode packageJson :: Maybe Object)
+  --     P.>>= KeyMap.lookup "dependencies"
+  --     P.>>= ( \case
+  --               Aeson.Object o -> KeyMap.lookup "graphiql" o
+  --               _ -> Nothing
+  --           )
+  --     P.>>= ( \case
+  --               Aeson.String s -> Just s
+  --               _ -> Nothing
+  --           )
+  --     & fromMaybe ""
+  pure "TODO"
+
+
+-- | Escape double quotes in SQL strings
+escDoubleQuotes :: Text -> Text
+escDoubleQuotes =
+  T.replace "\"" "\"\""
+
+
+-- | Quote a keyword in an SQL query
+quoteKeyword :: Text -> Text
+quoteKeyword keyword =
+  keyword
+    & escDoubleQuotes
+    & (\word -> "\"" <> word <> "\"")
+
+
+-- | Escape single quotes in SQL strings
+escSingleQuotes :: Text -> Text
+escSingleQuotes =
+  T.replace "'" "''"
+
+
+-- | Quote literal text in an SQL query
+quoteText :: Text -> Text
+quoteText keyword =
+  keyword
+    & escSingleQuotes
+    & (\word -> "'" <> word <> "'")
+
+
+headerJsonContent :: [(HeaderName, BS.ByteString)]
+headerJsonContent =
+  [("Content-Type", "application/json;charset=utf-8")]
+
+
+-- | Throw the specified server error with a message
+throwServerErrorWithMsg :: ServerError -> Text -> Servant.Handler a
+throwServerErrorWithMsg serverError errorMsg =
+  throwError $
+    serverError
+      { errHeaders = headerJsonContent
+      , errBody =
+          encode $
+            object
+              ["errors" .= [String errorMsg]]
+      }
+
+
+-- | Throw an "400 Bad Request" error with a message
+throwErr400WithMsg :: Text -> Servant.Handler a
+throwErr400WithMsg = throwServerErrorWithMsg err400
+
+
+-- | Throw an "404 Not Found" error with a message
+throwErr404WithMsg :: Text -> Servant.Handler a
+throwErr404WithMsg = throwServerErrorWithMsg err404
+
+
+-- | Throw an "500 Internal Server Error" error with a message
+throwErr500WithMsg :: Text -> Servant.Handler a
+throwErr500WithMsg = throwServerErrorWithMsg err500
+
+
+{-| Get the order of a linked list.
+ | Each tuple is `(name, previous name in list)`.
+ | The first's element previous name is `Nothing`.
+ | Tries to find the longest chain of elements if no start element is found.
+ | It's quite complicated to also handle incomplete orderings correctly.
+-}
+getOrderOfLinkedList :: [(Text, Maybe Text)] -> [Text]
+getOrderOfLinkedList tables =
+  let
+    findAfter :: [(Text, Maybe Text)] -> (Text, Maybe Text) -> [Text]
+    findAfter remaining (tableName, previousTableMb) =
+      P.maybeToList previousTableMb
+        <> case P.find ((P.== Just tableName) P.. P.snd) remaining of
+          Just found@(name, _) ->
+            let remaining' = List.filter (/= found) remaining
+            in  tableName : findAfter remaining' (name, Nothing)
+          Nothing -> [tableName]
+  in
+    if P.null tables
+      then []
+      else
+        let
+          sortByLength :: [[Text]] -> [[Text]]
+          sortByLength =
+            P.sortBy (\x y -> P.compare (P.length y) (P.length x))
+
+          chainsByLength =
+            tables
+              <&> findAfter tables
+              & sortByLength
+
+          -- First table ist always the (x, Nothing) table entry
+          firstElement =
+            case P.find ((P.== Nothing) P.. P.snd) tables of
+              Just tableEntry -> [P.fst tableEntry]
+              Nothing -> []
+        in
+          -- Sort them by length, combine them, and remove duplicates
+          ([firstElement] <> chainsByLength)
+            & P.concat
+            & List.nub
+
+
+getDbIdFromReadOnlyId :: Text -> IO (Maybe Text)
+getDbIdFromReadOnlyId readOnlyId = do
+  catchAll
+    ( do
+        dbId <- liftIO $ readSymbolicLink $ getReadOnlyFilePath readOnlyId
+        pure $ Just $ T.pack $ takeFileName dbId
+    )
+    ( \err -> do
+        when (not $ "does not exist" `P.isInfixOf` show err) $ do
+          P.putErrText $ "Error while reading readonly symlink:\n" <> show err
+        pure Nothing
+    )
+
+
+colToFileUrl :: Text -> Text -> Text -> Text -> Text
+colToFileUrl readonlyId tableName colName rowid =
+  T.decodeUtf8 $
+    BL.toStrict $
+      toLazyByteString $
+        encodePathSegments
+          [ "readonly"
+          , readonlyId
+          , "tables"
+          , tableName
+          , "columns"
+          , colName
+          , "files"
+          , "rowid"
+          , rowid
+          ]
+
+
+removeIfExists :: FilePath -> IO ()
+removeIfExists fileName =
+  let
+    handleExists :: IOError -> IO ()
+    handleExists e
+      | isDoesNotExistError e = pure ()
+      | P.otherwise = throwIO e
+  in
+    removeFile fileName `catch` handleExists
+
+
+runSqliteCommand :: ExternalAppContext -> FilePath -> BL.ByteString -> Servant.Handler Text
+runSqliteCommand ctx dbPath command = do
+  let
+    processConfig =
+      setStdin
+        (byteStringInput command)
+        $ setStdout createPipe
+        $ setStderr createPipe
+        $ proc ctx.sqlite [dbPath]
+
+  (exitCode, output) <- readProcessInterleaved processConfig
+
+  let outputText = P.decodeUtf8 $ BS.toStrict output
+
+  case exitCode of
+    ExitSuccess ->
+      pure outputText
+    ExitFailure _ ->
+      throwErr500WithMsg outputText
+
+
+-- | Similar to `sequence`, except it doesn't stop on the first error.
+collectErrorList :: [P.Either e b] -> P.Either [e] [b]
+collectErrorList results =
+  case P.lefts results of
+    [] -> P.Right (P.rights results)
+    lefts -> P.Left lefts
+
+
+{-|
+Similar to `sequence`, except it doesn't stop on the first error.
+What differentiates this from `collectErrorList` is
+that it also merges the errors into a single error message.
+-}
+collectAllErrorsAsText :: [P.Either Text b] -> P.Either Text [b]
+collectAllErrorsAsText results =
+  collectErrorList results
+    & mapLeft
+      ( \lefts ->
+          "Multiple errors occurred:\n" <> P.unlines lefts
+      )
+
+
+data DiffKind = Added | Removed | Kept
+  deriving (P.Eq, P.Ord, P.Show)
+
+
+{-| Run an action with a connection, retrying if the database is busy.
+| Necessary because of WAL mode:
+| https://sqlite.org/wal.html#sometimes_queries_return_sqlite_busy_in_wal_mode
+-}
+withRetryConn :: FilePath -> (Connection -> IO a) -> IO a
+withRetryConn filePath action = do
+  SS.withConnection filePath $ \conn -> do
+    SS.execute_ conn "PRAGMA busy_timeout = 5000;" -- 5 seconds
+    action conn

source/Server/Server.hs

@@ -0,0 +1,194 @@
+-- Necessary for servant-docs instances
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+module Server.Server (platformAPI, platformApp)
+where
+
+import Protolude (
+  Int,
+  Monoid (mempty),
+  Proxy (Proxy),
+  ($),
+ )
+import Protolude qualified as P
+
+import Data.Aeson (Object, Value, object)
+import Data.Aeson.KeyMap qualified as KeyMap
+import Data.ByteString.Lazy qualified as BL
+import Data.Text (Text)
+import Data.Text qualified as T
+import Network.Wai (Application)
+import Network.Wai.Parse (
+  defaultParseRequestBodyOptions,
+  setMaxRequestFilesSize,
+  setMaxRequestNumFiles,
+ )
+import Servant (Context (EmptyContext, (:.)), NoContent)
+import Servant.API (
+  Capture,
+  Get,
+  JSON,
+  PlainText,
+  Post,
+  ReqBody,
+  (:<|>) ((:<|>)),
+  (:>),
+ )
+import Servant.Docs (
+  DocCapture (DocCapture),
+  ToCapture (toCapture),
+  ToSample,
+  singleSample,
+  toSamples,
+ )
+import Servant.HTML.Blaze (HTML)
+import Servant.Multipart (
+  MultipartData (MultipartData),
+  MultipartOptions (generalOptions),
+  Tmp,
+  ToMultipartSample (toMultipartSamples),
+  defaultMultipartOptions,
+ )
+import Servant.Server (Server)
+import Servant.Server qualified as Servant
+import Text.Blaze.Internal (MarkupM)
+
+import AirGQL.Config (Config (maxDbSize), defaultConfig)
+import AirGQL.ExternalAppContext (ExternalAppContext)
+import AirGQL.Lib (SQLPost)
+import AirGQL.Servant.Database (
+  apiDatabaseSchemaGetHandler,
+  apiDatabaseVacuumPostHandler,
+ )
+import AirGQL.Servant.GraphQL (
+  gqlQueryGetHandler,
+  gqlQueryPostHandler,
+  playgroundDefaultQueryHandler,
+  readOnlyGqlPostHandler,
+  writeOnlyGqlPostHandler,
+ )
+import AirGQL.Servant.SqlQuery (sqlQueryPostHandler)
+import AirGQL.Types.SchemaConf (SchemaConf (pragmaConf), defaultSchemaConf)
+import AirGQL.Types.SqlQueryPostResult (SqlQueryPostResult)
+import AirGQL.Types.Types (GQLPost)
+
+
+{- FOURMOLU_DISABLE -}
+-- ATTENTION: Order of handlers matters!
+type PlatformAPI =
+  -- gqlQueryGetHandler
+  -- Redirect to GraphiQL playground
+  "graphql" :> Get '[HTML] NoContent
+
+  -- gqlQueryPostHandler
+  :<|> "graphql"
+      :> ReqBody '[JSON] GQLPost
+      :> Post '[JSON] Object
+
+  -- writeOnlyGqlPostHandler
+  :<|> "readonly" :> "graphql"
+          :> ReqBody '[JSON] GQLPost
+          :> Post '[JSON] Object
+
+  -- writeOnlyGqlPostHandler
+  :<|> "writeonly" :> "graphql"
+          :> ReqBody '[JSON] GQLPost
+          :> Post '[JSON] Object
+
+  -- playgroundDefaultQueryHandler
+  :<|> "playground" :> "default-query"
+          :> Get '[PlainText] Text
+
+  -- apiDatabaseSchemaGetHandler
+  :<|> "schema" :> Get '[PlainText] Text
+
+  -- apiDatabaseVacuumPostHandler
+  :<|> "vacuum" :> Post '[JSON] Object
+
+  -- sqlQueryPostHandler
+  :<|> "sql"
+          :> ReqBody '[JSON] SQLPost
+          :> Post '[JSON] SqlQueryPostResult
+
+{- FOURMOLU_ENABLE -}
+
+
+-- | Instances for automatic documentation generation via servant-docs
+instance ToSample (MultipartData Tmp) where
+  toSamples _ = singleSample $ MultipartData mempty mempty
+
+
+instance ToMultipartSample Tmp (MultipartData Tmp) where
+  toMultipartSamples _ = []
+
+
+instance ToSample Value where
+  toSamples _ = singleSample $ object []
+
+
+instance ToSample (KeyMap.KeyMap Value) where
+  toSamples _ = singleSample $ KeyMap.fromList []
+
+
+instance ToSample (MarkupM ()) where
+  toSamples _ = singleSample mempty
+
+
+instance ToSample BL.ByteString where
+  toSamples _ = singleSample mempty
+
+
+instance ToSample Text where
+  toSamples _ = singleSample mempty
+
+
+instance ToSample P.ByteString where
+  toSamples _ = singleSample mempty
+
+
+instance ToCapture (Capture "readonlyId" Text) where
+  toCapture _ = DocCapture "readonlyId" "Read-only ID of the database"
+
+
+instance ToCapture (Capture "dbId" Text) where
+  toCapture _ = DocCapture "dbId" "ID of the database to be served"
+
+
+platformAPI :: Proxy PlatformAPI
+platformAPI = Proxy
+
+
+platformServer :: ExternalAppContext -> P.FilePath -> Server PlatformAPI
+platformServer ctx filePath = do
+  let dbPath = T.pack filePath
+  gqlQueryGetHandler dbPath
+    :<|> gqlQueryPostHandler defaultSchemaConf dbPath
+    :<|> readOnlyGqlPostHandler dbPath
+    :<|> writeOnlyGqlPostHandler dbPath
+    :<|> playgroundDefaultQueryHandler dbPath
+    :<|> apiDatabaseSchemaGetHandler ctx dbPath
+    :<|> apiDatabaseVacuumPostHandler dbPath
+    :<|> sqlQueryPostHandler defaultSchemaConf.pragmaConf dbPath
+
+
+platformApp :: ExternalAppContext -> P.FilePath -> Application
+platformApp ctx filePath = do
+  let
+    maxFileSizeInByte :: Int = defaultConfig.maxDbSize
+
+    multipartOpts :: MultipartOptions Tmp
+    multipartOpts =
+      (defaultMultipartOptions (Proxy :: Proxy Tmp))
+        { generalOptions =
+            setMaxRequestNumFiles 1 $
+              setMaxRequestFilesSize
+                (P.fromIntegral maxFileSizeInByte)
+                defaultParseRequestBodyOptions
+        }
+
+    context :: Context '[MultipartOptions Tmp]
+    context =
+      multipartOpts :. EmptyContext
+
+  Servant.serveWithContext platformAPI context $ platformServer ctx filePath

stack-standalone.yaml

@@ -0,0 +1,18 @@
+resolver: lts-22.19
+
+extra-deps:
+  - double-x-encoding-1.1.1
+
+  - graphql-spice-1.0.2.0
+
+  - github: Airsequel/simple-sql-parser
+    commit: 680f2b77c53fcc086dc7d5f498f764ad2235b828
+
+allow-newer: true
+
+flags:
+  aeson-pretty:
+    lib-only: true
+
+  direct-sqlite:
+    mathfunctions: true

stack-standalone.yaml.lock

@@ -0,0 +1,37 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages:
+- completed:
+    hackage: double-x-encoding-1.1.1@sha256:f3b99d41172e51451532391ceefcd3cddcd6c4e494c6f744c3e91b2a31cc452d,1781
+    pantry-tree:
+      sha256: 383992adc327adfc2b5ecfc7e026105f8f162dccf76bb2b157c642e41ca8e28d
+      size: 188
+  original:
+    hackage: double-x-encoding-1.1.1
+- completed:
+    hackage: graphql-spice-1.0.2.0@sha256:97d22da8ec38342408bcd237e91e76ffcdad4f14df666f62b0b1ccba6bf39b87,2000
+    pantry-tree:
+      sha256: d60774d462c7c0af08c82b3f754e0ac49e598640e382c417e1809880192747cb
+      size: 937
+  original:
+    hackage: graphql-spice-1.0.2.0
+- completed:
+    name: simple-sql-parser
+    pantry-tree:
+      sha256: a7f399e93b6cb3056e43702b57ecda1a6a86dfdbeca4361ae3d2d27518ba4fe7
+      size: 3846
+    sha256: 5731c4471e011dede78b8f1d8812dd5eeb1c79024307f0b03f1855f9028e43e0
+    size: 137333
+    url: https://github.com/Airsequel/simple-sql-parser/archive/680f2b77c53fcc086dc7d5f498f764ad2235b828.tar.gz
+    version: 0.6.1
+  original:
+    url: https://github.com/Airsequel/simple-sql-parser/archive/680f2b77c53fcc086dc7d5f498f764ad2235b828.tar.gz
+snapshots:
+- completed:
+    sha256: e5cac927cf7ccbd52aa41476baa68b88c564ee6ddc3bc573dbf4210069287fe7
+    size: 713340
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/19.yaml
+  original: lts-22.19

tests/Tests/Utils.hs

@@ -0,0 +1,41 @@
+module Tests.Utils (
+  testRoot,
+  withDataDbConn,
+  withTestDbConn,
+) where
+
+import Protolude (
+  Bool (True),
+  FilePath,
+  IO,
+  ($),
+  (<>),
+ )
+
+import Database.SQLite.Simple qualified as SS
+import System.Directory (createDirectoryIfMissing, removePathForcibly)
+import System.FilePath ((</>))
+
+import AirGQL.Utils (removeIfExists, withRetryConn)
+
+
+testRoot :: FilePath
+testRoot = "../../airgql/tests"
+
+
+-- | Get a connection to a database in the test database directory
+withTestDbConn :: Bool -> FilePath -> (SS.Connection -> IO a) -> IO a
+withTestDbConn shouldSaveDbs testDbPath callback = do
+  removeIfExists $ testRoot </> testDbPath
+  withRetryConn
+    (if shouldSaveDbs then testRoot </> testDbPath else ":memory:")
+    callback
+
+
+-- | Get a connection to a test database in the main data directory
+withDataDbConn :: FilePath -> (SS.Connection -> IO a) -> IO a
+withDataDbConn testDbDir callback = do
+  let fullPath = "data" </> "databases" </> "_TEST_" <> testDbDir
+  removePathForcibly fullPath
+  createDirectoryIfMissing True fullPath
+  withRetryConn (fullPath </> "main.sqlite") callback

tests/introspection_query.gql

@@ -0,0 +1,96 @@
+query IntrospectionQuery {
+  __schema {
+
+    queryType { name }
+    mutationType { name }
+    subscriptionType { name }
+    types {
+      ...FullType
+    }
+    directives {
+      name
+      description
+
+      locations
+      args {
+        ...InputValue
+      }
+    }
+  }
+}
+
+fragment FullType on __Type {
+  kind
+  name
+  description
+
+  fields(includeDeprecated: true) {
+    name
+    description
+    args {
+      ...InputValue
+    }
+    type {
+      ...TypeRef
+    }
+    isDeprecated
+    deprecationReason
+  }
+  inputFields {
+    ...InputValue
+  }
+  interfaces {
+    ...TypeRef
+  }
+  enumValues(includeDeprecated: true) {
+    name
+    description
+    isDeprecated
+    deprecationReason
+  }
+  possibleTypes {
+    ...TypeRef
+  }
+}
+
+fragment InputValue on __InputValue {
+  name
+  description
+  type { ...TypeRef }
+  defaultValue
+
+
+}
+
+fragment TypeRef on __Type {
+  kind
+  name
+  ofType {
+    kind
+    name
+    ofType {
+      kind
+      name
+      ofType {
+        kind
+        name
+        ofType {
+          kind
+          name
+          ofType {
+            kind
+            name
+            ofType {
+              kind
+              name
+              ofType {
+                kind
+                name
+              }
+            }
+          }
+        }
+      }
+    }
+  }
+}