jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat: Added --dump-schema CLI option to dump JSON of dbStructure schema cache.

Browse Source 
Added postgrest-dump-schema to nix-shell returning a YAML dump of the test fixtures.

Authored-by: monacoremo <monacoremo>
This commit is contained in:
Remo Rechkemmer
2020-12-20 10:22:52 +01:00
committed by GitHub
parent fe09637711
commit bf141ca13f
5 changed files with 122 additions and 33 deletions
Download Patch File Download Diff File Expand all files Collapse all files
main/Main.hs
+65 -5
View File
@@ -1,11 +1,14 @@
{-# LANGUAGE CPP #-}
module Main where
module Main (main) where
import qualified Data.Aeson as Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Hasql.Connection as C
import qualified Hasql.Notifications as N
import qualified Hasql.Pool as P
import qualified Hasql.Session as S
import qualified Hasql.Transaction.Sessions as HT
import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate,
@@ -24,7 +27,9 @@ import Data.Text.IO (hPutStrLn)
import Data.Time.Clock (getCurrentTime)
import Network.Wai.Handler.Warp (defaultSettings, runSettings,
setHost, setPort, setServerName)
import System.CPUTime (getCPUTime)
import System.IO (BufferMode (..), hSetBuffering)
import Text.Printf (hPrintf)
import PostgREST.App (postgrest)
import PostgREST.Config (AppConfig (..), CLI (..), Command (..),
@@ -64,9 +69,6 @@ main = do
-- build the 'AppConfig' from the config file path
conf <- readValidateConfig $ cliPath opts
-- dump config and exit if option is set
when (cliCommand opts == CmdDumpConfig) $ dumpAppConfig conf
-- These are config values that can't be reloaded at runtime. Reloading some of them would imply restarting the web server.
let
host = configServerHost conf
@@ -86,6 +88,19 @@ main = do
poolTimeout = configDbPoolTimeout' conf
logLevel = configLogLevel conf
case cliCommand opts of
CmdDumpConfig ->
do
putStr $ dumpAppConfig conf
exitSuccess
CmdDumpSchema ->
do
dumpedSchema <- dumpSchema conf
putStrLn dumpedSchema
exitSuccess
CmdRun ->
pass
-- create connection pool with the provided settings, returns either a 'Connection' or a 'ConnectionError'. Does not throw.
pool <- P.acquire (poolSize, poolTimeout, dbUri)
@@ -158,6 +173,7 @@ main = do
putStrLn $ ("Listening on port " :: Text) <> show port
runSettings serverSettings postgrestApplication
-- Time constants
_32s :: Int
_32s = 32000000 :: Int -- 32 seconds
@@ -316,16 +332,60 @@ listener dbUri dbChannel pool refConf refDbStructure mvarConnectionStatus connWo
-- | Re-reads the config at runtime. Invoked on SIGUSR2.
-- | If it panics(config path was changed, invalid setting), it'll show an error but won't kill the main thread.
#ifndef mingw32_HOST_OS
reReadConfig :: FilePath -> IORef AppConfig -> IO ()
reReadConfig path refConf = do
conf <- readValidateConfig path
atomicWriteIORef refConf conf
putStrLn ("Config file reloaded" :: Text)
#endif
-- Utilitarian functions.
-- | Dump DbStructure schema to JSON
dumpSchema :: AppConfig -> IO LBS.ByteString
dumpSchema conf =
do
Right conn <- C.acquire . toS $ configDbUri conf
Right pgVersion <- S.run getPgVersion conn
let
getDbStructureTransaction =
HT.transaction HT.ReadCommitted HT.Read $
getDbStructure
(toList $ configDbSchemas conf)
(configDbExtraSearchPath conf)
pgVersion
(configDbPreparedStatements conf)
Right dbStructure <-
timeToStderr "Loaded schema in %.3f seconds" $
S.run getDbStructureTransaction conn
C.release conn
return $ Aeson.encode dbStructure
-- | Print the time taken to run an IO action to stderr with the given printf string
timeToStderr :: [Char] -> IO a -> IO a
timeToStderr fmtString a =
do
start <- getCPUTime
result <- a
end <- getCPUTime
let
duration :: Double
duration = fromIntegral (end - start) / picoseconds
hPrintf stderr (fmtString ++ "\n") duration
return result
-- | 10^12 picoseconds per second
picoseconds :: Double
picoseconds = 1000000000000
-- Utility functions.
#ifndef mingw32_HOST_OS
whenJust :: Applicative f => Maybe a -> (a -> f ()) -> f ()
whenJust (Just x) f = f x
whenJust Nothing _ = pass
#endif
whenNothing :: Applicative f => Maybe a -> f () -> f ()
whenNothing Nothing f = f
nix/tests.nix
+19
View File
@@ -17,6 +17,7 @@
, procps
, python3
, runtimeShell
, yq
}:
let
# Wrap the `test/with_tmp_db` script with the required dependencies from Nix.
@@ -125,6 +126,23 @@ let
${withTmpDb postgresql} "$rootdir/test/memory-tests.sh"
'';
dumpSchema =
name: postgresql:
checkedShellScript
name
''
rootdir="$(${git}/bin/git rev-parse --show-toplevel)"
cd "$rootdir"
env="$(cat ${postgrest.env})"
export PATH="$env/bin:$PATH"
${withTmpDb postgresql} \
${cabal-install}/bin/cabal v2-run ${devCabalOptions} --verbose=0 -- \
postgrest --dump-schema "$rootdir"/test/io-tests/configs/simple.config \
| ${yq}/bin/yq -y .
'';
in
# Create an environment that contains all the utility scripts for running tests
# that we defined above.
@@ -139,6 +157,7 @@ buildEnv
(testSpecIdempotence "postgrest-test-spec-idempotence" postgresql).bin
testSpecAllVersions.bin
(testIO "postgrest-test-io" postgresql).bin
(dumpSchema "postgrest-dump-schema" postgresql).bin
] ++ testSpecVersions;
}
# The memory tests have large dependencies (a profiled build of PostgREST)
postgrest.cabal
+1
View File
@@ -108,6 +108,7 @@ executable postgrest
main-is: Main.hs
hs-source-dirs: main
build-depends: base >= 4.9 && < 4.15
, aeson >= 1.4.7 && < 1.6
, auto-update >= 0.1.4 && < 0.2
, base64-bytestring >= 1 && < 1.3
, bytestring >= 0.10.8 && < 0.11
src/PostgREST/Config.hs
+21 -13
View File
@@ -76,7 +76,11 @@ data CLI = CLI
{ cliCommand :: Command
, cliPath :: FilePath }
data Command = CmdRun | CmdDumpConfig deriving (Eq)
data Command
= CmdRun
| CmdDumpConfig
| CmdDumpSchema
deriving (Eq)
-- | Config file settings for the server
data AppConfig = AppConfig {
@@ -148,10 +152,18 @@ readCLIShowHelp = customExecParser parserPrefs opts
cliParser :: Parser CLI
cliParser = CLI <$>
flag CmdRun CmdDumpConfig (
long "dump-config" <>
help "Dump loaded configuration and exit"
) <*>
(
flag CmdRun CmdDumpConfig (
long "dump-config" <>
help "Dump loaded configuration and exit"
)
<|>
flag CmdRun CmdDumpSchema (
long "dump-schema" <>
help "Dump loaded schema as JSON and exit (for debugging, output structure is unstable)"
)
)
<*>
strArgument (
metavar "FILENAME" <>
help "Path to configuration file"
@@ -237,15 +249,11 @@ readCLIShowHelp = customExecParser parserPrefs opts
|]
-- | Dump the config
dumpAppConfig :: AppConfig -> IO ()
dumpAppConfig conf = do
putStr dump
exitSuccess
dumpAppConfig :: AppConfig -> Text
dumpAppConfig conf =
unlines $ (\(k, v) -> k <> " = " <> v) <$>
pgrstSettings ++ appSettings
where
dump = unlines $ (\(k, v) -> k <> " = " <> v) <$>
pgrstSettings ++ appSettings
-- apply conf to all pgrst settings
pgrstSettings = (\(k, v) -> (k, v conf)) <$>
[("db-anon-role", q . configDbAnonRole)
src/PostgREST/Types.hs
+16 -15
View File
@@ -2,6 +2,7 @@
Module : PostgREST.Types
Description : PostgREST common types and functions used by the rest of the modules
-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
@@ -125,7 +126,7 @@ data DbStructure = DbStructure {
, dbPrimaryKeys :: [PrimaryKey]
, dbProcs :: ProcsMap
, pgVersion :: PgVersion
} deriving (Show, Eq)
} deriving (Show, Eq, Generic, JSON.ToJSON)
-- TODO Table could hold references to all its Columns
tableCols :: DbStructure -> Schema -> TableName -> [Column]
@@ -140,14 +141,14 @@ data PgArg = PgArg {
, pgaType :: Text
, pgaReq :: Bool
, pgaVar :: Bool
} deriving (Show, Eq, Ord)
} deriving (Show, Eq, Ord, Generic, JSON.ToJSON)
data PgType = Scalar QualifiedIdentifier | Composite QualifiedIdentifier deriving (Eq, Show, Ord)
data PgType = Scalar QualifiedIdentifier | Composite QualifiedIdentifier deriving (Eq, Show, Ord, Generic, JSON.ToJSON)
data RetType = Single PgType | SetOf PgType deriving (Eq, Show, Ord)
data RetType = Single PgType | SetOf PgType deriving (Eq, Show, Ord, Generic, JSON.ToJSON)
data ProcVolatility = Volatile | Stable | Immutable
deriving (Eq, Show, Ord)
deriving (Eq, Show, Ord, Generic, JSON.ToJSON)
data ProcDescription = ProcDescription {
pdSchema :: Schema
@@ -157,7 +158,7 @@ data ProcDescription = ProcDescription {
, pdReturnType :: RetType
, pdVolatility :: ProcVolatility
, pdHasVariadic :: Bool
} deriving (Show, Eq)
} deriving (Show, Eq, Generic, JSON.ToJSON)
-- Order by least number of args in the case of overloaded functions
instance Ord ProcDescription where
@@ -225,7 +226,7 @@ data Table = Table {
, tableName :: TableName
, tableDescription :: Maybe Text
, tableInsertable :: Bool
} deriving (Show, Ord)
} deriving (Show, Ord, Generic, JSON.ToJSON)
instance Eq Table where
Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2
@@ -233,7 +234,7 @@ instance Eq Table where
tableQi :: Table -> QualifiedIdentifier
tableQi Table{tableSchema=s, tableName=n} = QualifiedIdentifier s n
newtype ForeignKey = ForeignKey { fkCol :: Column } deriving (Show, Eq, Ord)
newtype ForeignKey = ForeignKey { fkCol :: Column } deriving (Show, Eq, Ord, Generic, JSON.ToJSON)
data Column =
Column {
@@ -249,7 +250,7 @@ data Column =
, colDefault :: Maybe Text
, colEnum :: [Text]
, colFK :: Maybe ForeignKey
} deriving (Show, Ord)
} deriving (Show, Ord, Generic, JSON.ToJSON)
instance Eq Column where
Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2
@@ -261,7 +262,7 @@ type ViewColumn = Column
data PrimaryKey = PrimaryKey {
pkTable :: Table
, pkName :: Text
} deriving (Show, Eq)
} deriving (Show, Eq, Generic, JSON.ToJSON)
data OrderDirection = OrderAsc | OrderDesc deriving (Eq)
instance Show OrderDirection where
@@ -286,7 +287,7 @@ data OrderTerm = OrderTerm {
data QualifiedIdentifier = QualifiedIdentifier {
qiSchema :: Schema
, qiName :: TableName
} deriving (Show, Eq, Ord, Generic)
} deriving (Show, Eq, Ord, Generic, JSON.ToJSON, JSON.ToJSONKey)
instance Hashable QualifiedIdentifier
-- | The relationship [cardinality](https://en.wikipedia.org/wiki/Cardinality_(data_modeling)).
@@ -294,7 +295,7 @@ instance Hashable QualifiedIdentifier
data Cardinality = O2M -- ^ one-to-many, previously known as Parent
| M2O -- ^ many-to-one, previously known as Child
| M2M -- ^ many-to-many, previously known as Many
deriving Eq
deriving (Eq, Generic, JSON.ToJSON)
instance Show Cardinality where
show O2M = "o2m"
show M2O = "m2o"
@@ -315,7 +316,7 @@ data Relation = Relation {
, relFColumns :: [Column]
, relType :: Cardinality
, relJunction :: Maybe Junction -- ^ Junction for M2M Cardinality
} deriving (Show, Eq)
} deriving (Show, Eq, Generic, JSON.ToJSON)
-- | Junction table on an M2M relationship
data Junction = Junction {
@@ -324,7 +325,7 @@ data Junction = Junction {
, junCols1 :: [Column]
, junConstraint2 :: Maybe ConstraintName
, junCols2 :: [Column]
} deriving (Show, Eq)
} deriving (Show, Eq, Generic, JSON.ToJSON)
isSelfReference :: Relation -> Bool
isSelfReference r = relTable r == relFTable r
@@ -510,7 +511,7 @@ fstFieldNames (Node (sel, _) _) =
data PgVersion = PgVersion {
pgvNum :: Int32
, pgvName :: Text
} deriving (Eq, Show)
} deriving (Eq, Show, Generic, JSON.ToJSON)
instance Ord PgVersion where
(PgVersion v1 _) `compare` (PgVersion v2 _) = v1 `compare` v2