diff --git a/main/Main.hs b/main/Main.hs index 11f390df4..3d69d7675 100644 --- a/main/Main.hs +++ b/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 diff --git a/nix/tests.nix b/nix/tests.nix index 23f9816d6..7eb969b07 100644 --- a/nix/tests.nix +++ b/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) diff --git a/postgrest.cabal b/postgrest.cabal index db223f162..a843a2327 100644 --- a/postgrest.cabal +++ b/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 diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs index 47ea6156c..9cd480a3d 100644 --- a/src/PostgREST/Config.hs +++ b/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) diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index ae13910b9..a09720e8b 100644 --- a/src/PostgREST/Types.hs +++ b/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,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