feat: Added --dump-schema CLI option to dump JSON of dbStructure sche…

…ma cache.

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

Authored-by: monacoremo <monacoremo>

main/Main.hs

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

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

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

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

@@ -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,15 +226,15 @@ 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
 
 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,15 +287,15 @@ 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)).
 -- | TODO: missing one-to-one
 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