refactor: Carve CLI and Version modules out of Config (#1806)

main/Main.hs

@@ -8,6 +8,7 @@ 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 Data.Map.Strict            as M
 import qualified Hasql.Connection           as C
 import qualified Hasql.Notifications        as N
 import qualified Hasql.Pool                 as P
@@ -27,11 +28,17 @@ import Data.Time.Clock          (getCurrentTime)
 import Network.Wai.Handler.Warp (defaultSettings, runSettings,
                                  setHost, setPort, setServerName)
 import System.CPUTime           (getCPUTime)
+import System.Environment       (getEnvironment)
 import System.IO                (BufferMode (..), hSetBuffering)
 import Text.Printf              (hPrintf)
 
 import PostgREST.App                   (postgrest)
-import PostgREST.Config
+import PostgREST.CLI                   (CLI (..), Command (..),
+                                        readCLIShowHelp)
+import PostgREST.Config                (AppConfig (..), Environment,
+                                        configDbPoolTimeout',
+                                        dumpAppConfig, readAppConfig,
+                                        readDbUriFile, readSecretFile)
 import PostgREST.DbStructure           (DbStructure, getDbStructure,
                                         getPgVersion)
 import PostgREST.DbStructure.PgVersion (PgVersion (..),
@@ -39,6 +46,9 @@ import PostgREST.DbStructure.PgVersion (PgVersion (..),
 import PostgREST.Error                 (PgError (PgError),
                                         checkIsFatal, errorPayload)
 import PostgREST.Query.Statements      (dbSettingsStatement)
+import PostgREST.Version               (prettyVersion)
+
+import qualified Data.Text as T
 
 import Protolude      hiding (hPutStrLn, head, toS)
 import Protolude.Conv (toS)
@@ -79,7 +89,7 @@ main = do
   env <- readEnvironment
 
   -- read command/path from commad line
-  CLI{cliCommand, cliPath} <- readCLIShowHelp env
+  CLI{cliCommand, cliPath} <- readCLIShowHelp . not $ M.null env
 
   -- build the 'AppConfig' from the config file path and env vars
   pathEnvConf <- either panic identity <$> readAppConfig mempty env cliPath Nothing Nothing
@@ -212,6 +222,10 @@ main = do
     putStrLn $ ("Listening on port " :: Text) <> show port
     runSettings serverSettings postgrestApplication
 
+readEnvironment :: IO Environment
+readEnvironment = getEnvironment <&> pgrst
+  where
+    pgrst env = M.filterWithKey (\k _ -> "PGRST_" `isPrefixOf` k) $ M.map T.pack $ M.fromList env
 
 -- Time constants
 _32s :: Int

postgrest.cabal

@@ -36,6 +36,7 @@ library
   hs-source-dirs:     src
   exposed-modules:    PostgREST.App
                       PostgREST.Auth
+                      PostgREST.CLI
                       PostgREST.Config
                       PostgREST.Config.JSPath
                       PostgREST.Config.Proxy
@@ -59,6 +60,7 @@ library
                       PostgREST.Request.Parsers
                       PostgREST.Request.Preferences
                       PostgREST.Request.Types
+                      PostgREST.Version
   other-modules:      Paths_postgrest
   build-depends:      base                      >= 4.9 && < 4.15
                     , HTTP                      >= 4000.3.7 && < 4000.4
@@ -131,6 +133,7 @@ executable postgrest
                     , auto-update         >= 0.1.4 && < 0.2
                     , base64-bytestring   >= 1 && < 1.3
                     , bytestring          >= 0.10.8 && < 0.11
+                    , containers          >= 0.5.7 && < 0.7
                     , directory           >= 1.2.6 && < 1.4
                     , either              >= 4.4.1 && < 5.1
                     , hasql               >= 1.4 && < 1.5

src/PostgREST/CLI.hs

@@ -0,0 +1,160 @@
+{-# LANGUAGE QuasiQuotes #-}
+module PostgREST.CLI
+  ( CLI (..)
+  , Command (..)
+  , readCLIShowHelp
+  ) where
+
+import qualified Options.Applicative as O
+import qualified Protolude.Conv      as Conv
+
+import Text.Heredoc (str)
+
+import PostgREST.Version (prettyVersion)
+
+import Protolude
+
+
+-- | Command line interface options
+data CLI = CLI
+  { cliCommand :: Command
+  , cliPath    :: Maybe FilePath
+  }
+
+data Command
+  = CmdRun
+  | CmdDumpConfig
+  | CmdDumpSchema
+
+-- | Read command line interface options. Also prints help.
+readCLIShowHelp :: Bool -> IO CLI
+readCLIShowHelp hasEnvironment =
+  O.customExecParser prefs opts
+  where
+    prefs = O.prefs $ O.showHelpOnError <> O.showHelpOnEmpty
+    opts = O.info parser $ O.fullDesc <> progDesc <> footer
+    parser = O.helper <*> exampleParser <*> cliParser
+
+    progDesc =
+      O.progDesc $
+        "PostgREST "
+        <> Conv.toS prettyVersion
+        <> " / create a REST API to an existing Postgres database"
+
+    footer =
+      O.footer $
+        "To run PostgREST, please pass the FILENAME argument"
+        <> " or set PGRST_ environment variables."
+
+    exampleParser =
+      O.infoOption exampleConfigFile $
+        O.long "example"
+        <> O.short 'e'
+        <> O.help "Show an example configuration file"
+
+    cliParser :: O.Parser CLI
+    cliParser =
+      CLI
+        <$> (dumpConfigFlag <|> dumpSchemaFlag)
+        <*> optionalIf hasEnvironment configFileOption
+
+    configFileOption =
+      O.strArgument $
+        O.metavar "FILENAME"
+        <> O.help "Path to configuration file (optional with PGRST_ environment variables)"
+
+    dumpConfigFlag =
+      O.flag CmdRun CmdDumpConfig $
+        O.long "dump-config"
+        <> O.help "Dump loaded configuration and exit"
+
+    dumpSchemaFlag =
+      O.flag CmdRun CmdDumpSchema $
+        O.long "dump-schema"
+        <> O.help "Dump loaded schema as JSON and exit (for debugging, output structure is unstable)"
+
+    optionalIf :: Alternative f => Bool -> f a -> f (Maybe a)
+    optionalIf True  = O.optional
+    optionalIf False = fmap Just
+
+exampleConfigFile :: [Char]
+exampleConfigFile =
+  [str|### REQUIRED:
+      |db-uri = "postgres://user:pass@localhost:5432/dbname"
+      |db-schema = "public"
+      |db-anon-role = "postgres"
+      |
+      |### OPTIONAL:
+      |## number of open connections in the pool
+      |db-pool = 10
+      |
+      |## Time to live, in seconds, for an idle database pool connection.
+      |db-pool-timeout = 10
+      |
+      |## extra schemas to add to the search_path of every request
+      |db-extra-search-path = "public"
+      |
+      |## limit rows in response
+      |# db-max-rows = 1000
+      |
+      |## stored proc to exec immediately after auth
+      |# db-pre-request = "stored_proc_name"
+      |
+      |## stored proc that overrides the root "/" spec
+      |## it must be inside the db-schema
+      |# db-root-spec = "stored_proc_name"
+      |
+      |## Notification channel for reloading the schema cache
+      |db-channel = "pgrst"
+      |
+      |## Enable or disable the notification channel
+      |db-channel-enabled = false
+      |
+      |## Enable in-database configuration
+      |db-config = true
+      |
+      |## how to terminate database transactions
+      |## possible values are:
+      |## commit (default)
+      |##   transaction is always committed, this can not be overriden
+      |## commit-allow-override
+      |##   transaction is committed, but can be overriden with Prefer tx=rollback header
+      |## rollback
+      |##   transaction is always rolled back, this can not be overriden
+      |## rollback-allow-override
+      |##   transaction is rolled back, but can be overriden with Prefer tx=commit header
+      |db-tx-end = "commit"
+      |
+      |## enable or disable prepared statements. disabling is only necessary when behind a connection pooler.
+      |## when disabled, statements will be parametrized but won't be prepared.
+      |db-prepared-statements = true
+      |
+      |server-host = "!4"
+      |server-port = 3000
+      |
+      |## unix socket location
+      |## if specified it takes precedence over server-port
+      |# server-unix-socket = "/tmp/pgrst.sock"
+      |
+      |## unix socket file mode
+      |## when none is provided, 660 is applied by default
+      |# server-unix-socket-mode = "660"
+      |
+      |## base url for swagger output
+      |openapi-server-proxy-uri = ""
+      |
+      |## choose a secret, JSON Web Key (or set) to enable JWT auth
+      |## (use "@filename" to load from separate file)
+      |# jwt-secret = "secret_with_at_least_32_characters"
+      |# jwt-aud = "your_audience_claim"
+      |jwt-secret-is-base64 = false
+      |
+      |## jspath to the role claim key
+      |jwt-role-claim-key = ".role"
+      |
+      |## content types to produce raw output
+      |# raw-media-types="image/png, image/jpg"
+      |
+      |## logging level, the admitted values are: crit, error, warn and info.
+      |log-level = "error"
+      |]

src/PostgREST/Config.hs

@@ -1,46 +1,28 @@
 {-|
 Module      : PostgREST.Config
-Description : Manages PostgREST configuration options.
+Description : Manages PostgREST configuration type and parser.
 
-This module provides a helper function to read the command line
-arguments using the optparse-applicative and the AppConfig type to store
-them.  It also can be used to define other middleware configuration that
-may be delegated to some sort of external configuration.
-
-It currently includes a hardcoded CORS policy but this could easly be
-turned in configurable behaviour if needed.
-
-Other hardcoded options such as the minimum version number also belong here.
 -}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE QuasiQuotes           #-}
-{-# LANGUAGE ScopedTypeVariables   #-}
-{-# LANGUAGE TemplateHaskell       #-}
 {-# OPTIONS_GHC -fno-warn-type-defaults #-}
 
 module PostgREST.Config
-  ( prettyVersion
+  ( AppConfig (..)
-  , docsVersion
+  , Environment
+  , JSPath
+  , JSPathExp(..)
   , LogLevel(..)
-  , CLI (..)
-  , Command (..)
-  , AppConfig (..)
   , Proxy(..)
   , configDbPoolTimeout'
   , dumpAppConfig
-  , Environment
+  , isMalformedProxyUri
-  , readCLIShowHelp
+  , parseSecret
-  , readEnvironment
   , readAppConfig
   , readDbUriFile
   , readSecretFile
-  , parseSecret
-  , JSPath
-  , JSPathExp(..)
-  , isMalformedProxyUri
   , toURI
   ) where
 
@@ -65,18 +47,8 @@ import Data.List               (lookup)
 import Data.List.NonEmpty      (fromList, toList)
 import Data.Maybe              (fromJust)
 import Data.Scientific         (floatingOrInteger)
-import Data.Version            (versionBranch)
-import Development.GitRev      (gitHash)
 import Numeric                 (readOct, showOct)
-import Options.Applicative     (Parser, customExecParser, flag,
-                                footer, fullDesc, help, helper, info,
-                                infoOption, long, metavar, prefs,
-                                progDesc, short, showHelpOnEmpty,
-                                showHelpOnError, strArgument)
-import Paths_postgrest         (version)
-import System.Environment      (getEnvironment)
 import System.Posix.Types      (FileMode)
-import Text.Heredoc            (str)
 
 import PostgREST.Config.JSPath (JSPath, JSPathExp (..), pRoleClaimKey)
 import PostgREST.Config.Proxy  (Proxy (..), isMalformedProxyUri,
@@ -85,17 +57,7 @@ import PostgREST.Config.Proxy  (Proxy (..), isMalformedProxyUri,
 import Protolude      hiding (Proxy, toList, toS)
 import Protolude.Conv (toS)
 
--- | Command line interface options
-data CLI = CLI
-  { cliCommand :: Command
-  , cliPath    :: Maybe FilePath }
 
-data Command
-  = CmdRun
-  | CmdDumpConfig
-  | CmdDumpSchema
-
--- | Config file settings for the server
 data AppConfig = AppConfig {
     configAppSettings           :: [(Text, Text)]
   , configDbAnonRole            :: Text
@@ -139,148 +101,6 @@ instance Show LogLevel where
   show LogWarn  = "warn"
   show LogInfo  = "info"
 
--- | User friendly version number
-prettyVersion :: Text
-prettyVersion =
-  T.intercalate "." (map show $ versionBranch version) <> gitRev
-  where
-    gitRev =
-      if $(gitHash) == "UNKNOWN"
-        then mempty
-        else " (" <> T.take 7 $(gitHash) <> ")"
-
--- | Version number used in docs
-docsVersion :: Text
-docsVersion = "v" <> T.dropEnd 1 (T.dropWhileEnd (/= '.') prettyVersion)
-
--- | Read command line interface options. Also prints help.
-readCLIShowHelp :: Environment -> IO CLI
-readCLIShowHelp env = customExecParser parserPrefs opts
-  where
-    parserPrefs = prefs $ showHelpOnError <> showHelpOnEmpty
-
-    opts = info (helper <*> exampleParser <*> cliParser) $
-             fullDesc
-             <> progDesc (
-                 "PostgREST "
-                 <> toS prettyVersion
-                 <> " / create a REST API to an existing Postgres database"
-               )
-             <> footer "To run PostgREST, please pass the FILENAME argument or set PGRST_ environment variables."
-
-    cliParser :: Parser CLI
-    cliParser = CLI <$>
-      (
-        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)"
-        )
-      )
-      <*>
-      optionalWithEnvironment (strArgument (
-        metavar "FILENAME" <>
-        help "Path to configuration file (optional with PGRST_ environment variables)"
-      ))
-
-    optionalWithEnvironment :: Alternative f => f a -> f (Maybe a)
-    optionalWithEnvironment v
-      | M.null env = Just <$> v
-      | otherwise  = optional v
-
-    exampleParser :: Parser (a -> a)
-    exampleParser =
-      infoOption example (
-        long "example" <>
-        short 'e' <>
-        help "Show an example configuration file"
-      )
-
-    example =
-      [str|### REQUIRED:
-          |db-uri = "postgres://user:pass@localhost:5432/dbname"
-          |db-schema = "public"
-          |db-anon-role = "postgres"
-          |
-          |### OPTIONAL:
-          |## number of open connections in the pool
-          |db-pool = 10
-          |
-          |## Time to live, in seconds, for an idle database pool connection.
-          |db-pool-timeout = 10
-          |
-          |## extra schemas to add to the search_path of every request
-          |db-extra-search-path = "public"
-          |
-          |## limit rows in response
-          |# db-max-rows = 1000
-          |
-          |## stored proc to exec immediately after auth
-          |# db-pre-request = "stored_proc_name"
-          |
-          |## stored proc that overrides the root "/" spec
-          |## it must be inside the db-schema
-          |# db-root-spec = "stored_proc_name"
-          |
-          |## Notification channel for reloading the schema cache
-          |db-channel = "pgrst"
-          |
-          |## Enable or disable the notification channel
-          |db-channel-enabled = false
-          |
-          |## Enable in-database configuration
-          |db-config = true
-          |
-          |## how to terminate database transactions
-          |## possible values are:
-          |## commit (default)
-          |##   transaction is always committed, this can not be overriden
-          |## commit-allow-override
-          |##   transaction is committed, but can be overriden with Prefer tx=rollback header
-          |## rollback
-          |##   transaction is always rolled back, this can not be overriden
-          |## rollback-allow-override
-          |##   transaction is rolled back, but can be overriden with Prefer tx=commit header
-          |db-tx-end = "commit"
-          |
-          |## enable or disable prepared statements. disabling is only necessary when behind a connection pooler.
-          |## when disabled, statements will be parametrized but won't be prepared.
-          |db-prepared-statements = true
-          |
-          |server-host = "!4"
-          |server-port = 3000
-          |
-          |## unix socket location
-          |## if specified it takes precedence over server-port
-          |# server-unix-socket = "/tmp/pgrst.sock"
-          |
-          |## unix socket file mode
-          |## when none is provided, 660 is applied by default
-          |# server-unix-socket-mode = "660"
-          |
-          |## base url for swagger output
-          |openapi-server-proxy-uri = ""
-          |
-          |## choose a secret, JSON Web Key (or set) to enable JWT auth
-          |## (use "@filename" to load from separate file)
-          |# jwt-secret = "secret_with_at_least_32_characters"
-          |# jwt-aud = "your_audience_claim"
-          |jwt-secret-is-base64 = false
-          |
-          |## jspath to the role claim key
-          |jwt-role-claim-key = ".role"
-          |
-          |## content types to produce raw output
-          |# raw-media-types="image/png, image/jpg"
-          |
-          |## logging level, the admitted values are: crit, error, warn and info.
-          |log-level = "error"
-          |]
-
 -- | Dump the config
 dumpAppConfig :: AppConfig -> Text
 dumpAppConfig conf =
@@ -568,13 +388,6 @@ parseSecret bytes =
   secret = JWT.JWKSet [JWT.fromKeyMaterial keyMaterial]
   keyMaterial = JWT.OctKeyMaterial . JWT.OctKeyParameters $ JOSE.Base64Octets bytes
 
-type Environment = M.Map [Char] Text
-
-readEnvironment :: IO Environment
-readEnvironment = getEnvironment <&> pgrst
-  where
-    pgrst env = M.filterWithKey (\k _ -> "PGRST_" `isPrefixOf` k) $ M.map T.pack $ M.fromList env
-
 -- | Read the JWT secret from a file if configJwtSecret is actually a filepath(has @ as its prefix).
 -- | To check if the JWT secret is provided is in fact a file path, it must be decoded as 'Text' to be processed.
 readSecretFile :: Maybe B.ByteString -> IO (Maybe B.ByteString)
@@ -590,3 +403,5 @@ readDbUriFile :: Text -> IO (Maybe Text)
 readDbUriFile dbUri = case T.stripPrefix "@" dbUri of
   Nothing       -> return Nothing
   Just filename -> Just . T.strip <$> readFile (toS filename)
+
+type Environment = M.Map [Char] Text

src/PostgREST/OpenAPI.hs

@@ -22,9 +22,7 @@ import Control.Lens (at, (.~), (?~))
 import Data.Swagger
 
 import PostgREST.Config               (AppConfig (..), Proxy (..),
-                                       docsVersion,
+                                       isMalformedProxyUri, toURI)
-                                       isMalformedProxyUri,
-                                       prettyVersion, toURI)
 import PostgREST.DbStructure          (DbStructure (..), tableCols,
                                        tablePKCols)
 import PostgREST.DbStructure.Proc     (PgArg (..),
@@ -32,6 +30,7 @@ import PostgREST.DbStructure.Proc     (PgArg (..),
 import PostgREST.DbStructure.Relation (PrimaryKey (..))
 import PostgREST.DbStructure.Table    (Column (..), ForeignKey (..),
                                        Table (..))
+import PostgREST.Version              (docsVersion, prettyVersion)
 
 import PostgREST.ContentType
 

src/PostgREST/Version.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
+module PostgREST.Version
+  ( docsVersion
+  , prettyVersion
+  ) where
+
+import qualified Data.Text as T
+
+import Data.Version       (versionBranch)
+import Development.GitRev (gitHash)
+import Paths_postgrest    (version)
+
+import Protolude
+
+
+-- | User friendly version number
+prettyVersion :: Text
+prettyVersion =
+  T.intercalate "." (map show $ versionBranch version) <> gitRev
+  where
+    gitRev =
+      if $(gitHash) == "UNKNOWN"
+        then mempty
+        else " (" <> T.take 7 $(gitHash) <> ")"
+
+-- | Version number used in docs
+docsVersion :: Text
+docsVersion = "v" <> T.dropEnd 1 (T.dropWhileEnd (/= '.') prettyVersion)

test/Feature/OpenApiSpec.hs

@@ -11,8 +11,8 @@ import Network.HTTP.Types
 import Test.Hspec         hiding (pendingWith)
 import Test.Hspec.Wai
 
-import PostgREST.Config (docsVersion)
+import PostgREST.Version (docsVersion)
-import Protolude        hiding (get)
+import Protolude         hiding (get)
 import SpecHelper
 
 spec :: SpecWith ((), Application)