diff --git a/main/Main.hs b/main/Main.hs index 26eda3a44..c3d5bc8ac 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -30,13 +30,16 @@ import System.IO (BufferMode (..), hSetBuffering) import PostgREST.App (postgrest) import PostgREST.Auth (parseSecret) import PostgREST.Config (AppConfig (..), configPoolTimeout', - prettyVersion, readAppConfig, readPathShowHelp, loadDbUriFile, loadSecretFile) + loadDbUriFile, loadSecretFile, + prettyVersion, readAppConfig, + readPathShowHelp) import PostgREST.DbStructure (getDbStructure, getPgVersion) import PostgREST.Error (PgError (PgError), checkIsFatal, errorPayload) import PostgREST.OpenAPI (isMalformedProxyUri) import PostgREST.Types (ConnectionStatus (..), DbStructure, - PgVersion (..), minimumPgVersion) + LogSetup (..), PgVersion (..), + minimumPgVersion) import Protolude hiding (hPutStrLn, head, toS) import Protolude.Conv (toS) @@ -284,6 +287,7 @@ main = do let postgrestApplication = postgrest + LogStdout conf refDbStructure pool diff --git a/postgrest.cabal b/postgrest.cabal index 8a0f06a11..4d1287ccc 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -41,6 +41,7 @@ library PostgREST.Types other-modules: Paths_postgrest PostgREST.Private.Common + PostgREST.Private.ProxyUri PostgREST.Private.QueryFragment hs-source-dirs: src build-depends: base >= 4.9 && < 4.15 diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 1d336c8f3..064d1128b 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -27,11 +27,9 @@ import qualified Hasql.Transaction as H import qualified Hasql.Transaction as HT import qualified Hasql.Transaction.Sessions as HT -import Data.Function (id) -import Data.IORef (IORef, readIORef) -import Data.Time.Clock (UTCTime) -import Network.HTTP.Types.URI (renderSimpleQuery) -import Network.Wai.Middleware.RequestLogger (logStdout) +import Data.IORef (IORef, readIORef) +import Data.Time.Clock (UTCTime) +import Network.HTTP.Types.URI (renderSimpleQuery) import Control.Applicative import Data.Maybe @@ -67,10 +65,9 @@ import PostgREST.Types import Protolude hiding (Proxy, intercalate, toS) import Protolude.Conv (toS) -postgrest :: AppConfig -> IORef (Maybe DbStructure) -> P.Pool -> IO UTCTime -> IO () -> Application -postgrest conf refDbStructure pool getTime worker = - let middle = (if configQuiet conf then id else logStdout) . defaultMiddle in - middle $ \ req respond -> do +postgrest :: LogSetup -> AppConfig -> IORef (Maybe DbStructure) -> P.Pool -> IO UTCTime -> IO () -> Application +postgrest logs conf refDbStructure pool getTime worker = + pgrstMiddleware logs $ \ req respond -> do time <- getTime body <- strictRequestBody req maybeDbStructure <- readIORef refDbStructure diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs index e83fd0bb2..e30536e1a 100644 --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -21,7 +21,6 @@ module PostgREST.Config ( prettyVersion , docsVersion , readPathShowHelp , readAppConfig - , corsPolicy , AppConfig (..) , configPoolTimeout' , loadSecretFile @@ -29,35 +28,30 @@ module PostgREST.Config ( prettyVersion ) where -import Crypto.JWT (JWKSet) import qualified Data.ByteString as B -import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as BS -import qualified Data.CaseInsensitive as CI import qualified Data.Configurator as C import qualified Text.PrettyPrint.ANSI.Leijen as L -import Control.Lens (preview) -import Control.Monad (fail) -import Crypto.JWT (StringOrURI, stringOrUri) -import Data.List (lookup) -import Data.List.NonEmpty (fromList) -import Data.Scientific (floatingOrInteger) -import Data.Text (pack, replace, dropEnd, dropWhileEnd, - intercalate, splitOn, strip, stripPrefix, take, - unpack) -import Data.Text.IO (hPutStrLn) -import Data.Version (versionBranch) -import Development.GitRev (gitHash) -import Network.Wai.Middleware.Cors (CorsResourcePolicy (..)) -import Numeric (readOct) -import Paths_postgrest (version) -import System.IO.Error (IOError) -import System.Posix.Types (FileMode) +import Control.Lens (preview) +import Control.Monad (fail) +import Crypto.JWT (JWKSet, StringOrURI, stringOrUri) +import Data.List.NonEmpty (fromList) +import Data.Scientific (floatingOrInteger) +import Data.Text (dropEnd, dropWhileEnd, intercalate, pack, + replace, splitOn, strip, stripPrefix, take, + unpack) +import Data.Text.IO (hPutStrLn) +import Data.Version (versionBranch) +import Development.GitRev (gitHash) +import Numeric (readOct) +import Paths_postgrest (version) +import System.IO.Error (IOError) +import System.Posix.Types (FileMode) import Control.Applicative import Data.Monoid -import Network.Wai import Options.Applicative hiding (str) import Text.Heredoc import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) @@ -65,7 +59,7 @@ import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) import PostgREST.Parsers (pRoleClaimKey) import PostgREST.Types (JSPath, JSPathExp (..)) import Protolude hiding (concat, hPutStrLn, intercalate, null, - take, toS, (<>), replace) + replace, take, toS, (<>)) import Protolude.Conv (toS) @@ -89,8 +83,7 @@ data AppConfig = AppConfig { , configPoolSize :: Int , configPoolTimeout :: Int , configMaxRows :: Maybe Integer - , configReqCheck :: Maybe Text - , configQuiet :: Bool + , configPreReq :: Maybe Text , configSettings :: [(Text, Text)] , configRoleClaimKey :: Either Text JSPath , configExtraSearchPath :: [Text] @@ -105,30 +98,6 @@ configPoolTimeout' :: (Fractional a) => AppConfig -> a configPoolTimeout' = fromRational . toRational . configPoolTimeout - -defaultCorsPolicy :: CorsResourcePolicy -defaultCorsPolicy = CorsResourcePolicy Nothing - ["GET", "POST", "PATCH", "PUT", "DELETE", "OPTIONS"] ["Authorization"] Nothing - (Just $ 60*60*24) False False True - --- | CORS policy to be used in by Wai Cors middleware -corsPolicy :: Request -> Maybe CorsResourcePolicy -corsPolicy req = case lookup "origin" headers of - Just origin -> Just defaultCorsPolicy { - corsOrigins = Just ([origin], True) - , corsRequestHeaders = "Authentication":accHeaders - , corsExposedHeaders = Just [ - "Content-Encoding", "Content-Location", "Content-Range", "Content-Type" - , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit" - ] - } - Nothing -> Nothing - where - headers = requestHeaders req - accHeaders = case lookup "access-control-request-headers" headers of - Just hdrs -> map (CI.mk . toS . strip . toS) $ BS.split ',' hdrs - Nothing -> [] - -- | User friendly version number prettyVersion :: Text prettyVersion = @@ -257,7 +226,6 @@ readAppConfig cfgPath = do <*> (fromMaybe 10 <$> optInt "db-pool-timeout") <*> optInt "max-rows" <*> optString "pre-request" - <*> pure False <*> (fmap (fmap coerceText) <$> C.subassocs "app.settings" C.value) <*> (maybe (Right [JSPKey "role"]) parseRoleClaimKey <$> optValue "role-claim-key") <*> (maybe ["public"] splitOnCommas <$> optValue "db-extra-search-path") diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index 5697330fa..74e5df9a1 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -1,6 +1,6 @@ {-| Module : PostgREST.Middleware -Description : Sets the PostgreSQL GUCs, role, search_path and pre-request function. Validates JWT. +Description : Sets CORS policy. Also the PostgreSQL GUCs, role, search_path and pre-request function. -} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleContexts #-} @@ -8,20 +8,29 @@ Description : Sets the PostgreSQL GUCs, role, search_path and pre-request functi module PostgREST.Middleware where -import qualified Data.Aeson as JSON -import qualified Data.HashMap.Strict as M -import Data.Scientific (FPFormat (..), formatScientific, - isInteger) -import qualified Hasql.Transaction as H +import qualified Data.Aeson as JSON +import qualified Data.ByteString.Char8 as BS +import qualified Data.CaseInsensitive as CI +import Data.Function (id) +import qualified Data.HashMap.Strict as M +import Data.List (lookup) +import Data.Scientific (FPFormat (..), + formatScientific, isInteger) +import Data.Text (strip) +import qualified Hasql.Transaction as H -import Network.Wai (Application, Response) -import Network.Wai.Middleware.Cors (cors) -import Network.Wai.Middleware.Gzip (def, gzip) -import Network.Wai.Middleware.Static (only, staticPolicy) +import Network.Wai (Application, Request, + Response, requestHeaders) +import Network.Wai.Middleware.Cors (CorsResourcePolicy (..), + cors) +import Network.Wai.Middleware.Gzip (def, gzip) +import Network.Wai.Middleware.RequestLogger (logStdout) +import Network.Wai.Middleware.Static (only, staticPolicy) import PostgREST.ApiRequest (ApiRequest (..)) -import PostgREST.Config (AppConfig (..), corsPolicy) +import PostgREST.Config (AppConfig (..)) import PostgREST.QueryBuilder (setLocalQuery, setLocalSearchPathQuery) +import PostgREST.Types (LogSetup (..)) import Protolude hiding (head, toS) import Protolude.Conv (toS) @@ -31,7 +40,7 @@ runPgLocals :: AppConfig -> M.HashMap Text JSON.Value -> ApiRequest -> H.Transaction Response runPgLocals conf claims app req = do H.sql $ toS . mconcat $ setSearchPathSql : setRoleSql ++ claimsSql ++ [methodSql, pathSql] ++ headersSql ++ cookiesSql ++ appSettingsSql - traverse_ H.sql customReqCheck + traverse_ H.sql preReq app req where methodSql = setLocalQuery mempty ("request.method", toS $ iMethod req) @@ -46,14 +55,38 @@ runPgLocals conf claims app req = do -- role claim defaults to anon if not specified in jwt claimsWithRole = M.union claims (M.singleton "role" anon) anon = JSON.String . toS $ configAnonRole conf - customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf + preReq = (\f -> "select " <> toS f <> "();") <$> configPreReq conf -defaultMiddle :: Application -> Application -defaultMiddle = - gzip def +pgrstMiddleware :: LogSetup -> Application -> Application +pgrstMiddleware logs = + (if logs == LogQuiet then id else logStdout) + . gzip def . cors corsPolicy . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) +defaultCorsPolicy :: CorsResourcePolicy +defaultCorsPolicy = CorsResourcePolicy Nothing + ["GET", "POST", "PATCH", "PUT", "DELETE", "OPTIONS"] ["Authorization"] Nothing + (Just $ 60*60*24) False False True + +-- | CORS policy to be used in by Wai Cors middleware +corsPolicy :: Request -> Maybe CorsResourcePolicy +corsPolicy req = case lookup "origin" headers of + Just origin -> Just defaultCorsPolicy { + corsOrigins = Just ([origin], True) + , corsRequestHeaders = "Authentication":accHeaders + , corsExposedHeaders = Just [ + "Content-Encoding", "Content-Location", "Content-Range", "Content-Type" + , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit" + ] + } + Nothing -> Nothing + where + headers = requestHeaders req + accHeaders = case lookup "access-control-request-headers" headers of + Just hdrs -> map (CI.mk . toS . strip . toS) $ BS.split ',' hdrs + Nothing -> [] + unquoted :: JSON.Value -> Text unquoted (JSON.String t) = t unquoted (JSON.Number n) = diff --git a/src/PostgREST/OpenAPI.hs b/src/PostgREST/OpenAPI.hs index f98978271..c4b2fcf3f 100644 --- a/src/PostgREST/OpenAPI.hs +++ b/src/PostgREST/OpenAPI.hs @@ -6,8 +6,8 @@ Description : Generates the OpenAPI output module PostgREST.OpenAPI ( encodeOpenAPI -, isMalformedProxyUri , pickProxy +, isMalformedProxyUri ) where import qualified Data.HashSet.InsOrd as Set @@ -20,20 +20,21 @@ import Data.String (IsString (..)) import Data.Text (append, breakOn, dropWhile, init, intercalate, pack, tail, toLower, unpack) -import Network.URI (URI (..), URIAuth (..), - isAbsoluteURI, parseURI) +import Network.URI (URI (..), URIAuth (..)) import Control.Lens import Data.Swagger -import PostgREST.ApiRequest (ContentType (..)) -import PostgREST.Config (docsVersion, prettyVersion) -import PostgREST.Types (Column (..), ForeignKey (..), PgArg (..), - PrimaryKey (..), ProcDescription (..), - Proxy (..), Table (..), toMime) -import Protolude hiding (Proxy, dropWhile, get, - intercalate, toLower, toS, (&)) -import Protolude.Conv (toS) +import PostgREST.ApiRequest (ContentType (..)) +import PostgREST.Config (docsVersion, prettyVersion) +import PostgREST.Private.ProxyUri (isMalformedProxyUri, toURI) +import PostgREST.Types (Column (..), ForeignKey (..), + PgArg (..), PrimaryKey (..), + ProcDescription (..), Proxy (..), + Table (..), toMime) +import Protolude hiding (Proxy, dropWhile, get, + intercalate, toLower, toS, (&)) +import Protolude.Conv (toS) makeMimeList :: [ContentType] -> MimeList makeMimeList cs = MimeList $ map (fromString . toS . toMime) cs @@ -306,24 +307,6 @@ postgrestSpec pds ti (s, h, p, b) sd pks = (mempty :: Swagger) encodeOpenAPI :: [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Maybe Text -> [PrimaryKey] -> LByteString encodeOpenAPI pds ti uri sd pks = encode $ postgrestSpec pds ti uri sd pks -{-| - Test whether a proxy uri is malformed or not. - A valid proxy uri should be an absolute uri without query and user info, - only http(s) schemes are valid, port number range is 1-65535. - - For example - http://postgrest.com/openapi.json - https://postgrest.com:8080/openapi.json --} -isMalformedProxyUri :: Maybe Text -> Bool -isMalformedProxyUri Nothing = False -isMalformedProxyUri (Just uri) - | isAbsoluteURI (toS uri) = not $ isUriValid $ toURI uri - | otherwise = True - -toURI :: Text -> URI -toURI uri = fromJust $ parseURI (toS uri) - pickProxy :: Maybe Text -> Maybe Proxy pickProxy proxy | isNothing proxy = Nothing @@ -352,40 +335,3 @@ pickProxy proxy ("", "http") -> 80 ("", "https") -> 443 _ -> readPort $ unpack $ tail $ pack port' - -isUriValid:: URI -> Bool -isUriValid = fAnd [isSchemeValid, isQueryValid, isAuthorityValid] - -fAnd :: [a -> Bool] -> a -> Bool -fAnd fs x = all ($ x) fs - -isSchemeValid :: URI -> Bool -isSchemeValid URI {uriScheme = s} - | toLower (pack s) == "https:" = True - | toLower (pack s) == "http:" = True - | otherwise = False - -isQueryValid :: URI -> Bool -isQueryValid URI {uriQuery = ""} = True -isQueryValid _ = False - -isAuthorityValid :: URI -> Bool -isAuthorityValid URI {uriAuthority = a} - | isJust a = fAnd [isUserInfoValid, isHostValid, isPortValid] $ fromJust a - | otherwise = False - -isUserInfoValid :: URIAuth -> Bool -isUserInfoValid URIAuth {uriUserInfo = ""} = True -isUserInfoValid _ = False - -isHostValid :: URIAuth -> Bool -isHostValid URIAuth {uriRegName = ""} = False -isHostValid _ = True - -isPortValid :: URIAuth -> Bool -isPortValid URIAuth {uriPort = ""} = True -isPortValid URIAuth {uriPort = (':':p)} = - case readMaybe p of - Just i -> i > (0 :: Integer) && i < 65536 - Nothing -> False -isPortValid _ = False diff --git a/src/PostgREST/Private/ProxyUri.hs b/src/PostgREST/Private/ProxyUri.hs new file mode 100644 index 000000000..2a2311a99 --- /dev/null +++ b/src/PostgREST/Private/ProxyUri.hs @@ -0,0 +1,72 @@ + +{-| +Module : PostgREST.Private.ProxyUri +Description : Proxy Uri validator +-} +module PostgREST.Private.ProxyUri ( + isMalformedProxyUri +, toURI +) where + +import Data.Maybe (fromJust) +import Data.Text (pack, toLower) +import Network.URI (URI (..), URIAuth (..), isAbsoluteURI, parseURI) + +import Protolude hiding (Proxy, dropWhile, get, intercalate, + toLower, toS, (&)) +import Protolude.Conv (toS) + +{-| + Test whether a proxy uri is malformed or not. + A valid proxy uri should be an absolute uri without query and user info, + only http(s) schemes are valid, port number range is 1-65535. + + For example + http://postgrest.com/openapi.json + https://postgrest.com:8080/openapi.json +-} +isMalformedProxyUri :: Maybe Text -> Bool +isMalformedProxyUri Nothing = False +isMalformedProxyUri (Just uri) + | isAbsoluteURI (toS uri) = not $ isUriValid $ toURI uri + | otherwise = True + +toURI :: Text -> URI +toURI uri = fromJust $ parseURI (toS uri) + +isUriValid:: URI -> Bool +isUriValid = fAnd [isSchemeValid, isQueryValid, isAuthorityValid] + +fAnd :: [a -> Bool] -> a -> Bool +fAnd fs x = all ($ x) fs + +isSchemeValid :: URI -> Bool +isSchemeValid URI {uriScheme = s} + | toLower (pack s) == "https:" = True + | toLower (pack s) == "http:" = True + | otherwise = False + +isQueryValid :: URI -> Bool +isQueryValid URI {uriQuery = ""} = True +isQueryValid _ = False + +isAuthorityValid :: URI -> Bool +isAuthorityValid URI {uriAuthority = a} + | isJust a = fAnd [isUserInfoValid, isHostValid, isPortValid] $ fromJust a + | otherwise = False + +isUserInfoValid :: URIAuth -> Bool +isUserInfoValid URIAuth {uriUserInfo = ""} = True +isUserInfoValid _ = False + +isHostValid :: URIAuth -> Bool +isHostValid URIAuth {uriRegName = ""} = False +isHostValid _ = True + +isPortValid :: URIAuth -> Bool +isPortValid URIAuth {uriPort = ""} = True +isPortValid URIAuth {uriPort = (':':p)} = + case readMaybe p of + Just i -> i > (0 :: Integer) && i < 65536 + Nothing -> False +isPortValid _ = False diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 2cb11d586..0a74bffba 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -535,3 +535,6 @@ data ConnectionStatus | Connected PgVersion | FatalConnectionError Text deriving (Eq, Show) + +-- | Logging setup +data LogSetup = LogQuiet | LogStdout deriving (Eq, Show) diff --git a/test/Main.hs b/test/Main.hs index 2b4c6b95b..dc499883c 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -15,7 +15,7 @@ import Test.Hspec import PostgREST.App (postgrest) import PostgREST.Config (AppConfig (..)) import PostgREST.DbStructure (getDbStructure, getPgVersion) -import PostgREST.Types (pgVersion95, pgVersion96) +import PostgREST.Types (LogSetup (..), pgVersion95, pgVersion96) import Protolude hiding (toList, toS) import Protolude.Conv (toS) import SpecHelper @@ -65,12 +65,12 @@ main = do let -- For tests that run with the same refDbStructure - app cfg = return ((), postgrest (cfg testDbConn) refDbStructure pool getTime $ pure ()) + app cfg = return ((), postgrest LogQuiet (cfg testDbConn) refDbStructure pool getTime $ pure ()) -- For tests that run with a different DbStructure(depends on configSchemas) appDbs cfg = do dbs <- (newIORef . Just) =<< setupDbStructure pool (configSchemas $ cfg testDbConn) actualPgVersion - return ((), postgrest (cfg testDbConn) dbs pool getTime $ pure ()) + return ((), postgrest LogQuiet (cfg testDbConn) dbs pool getTime $ pure ()) let withApp = app testCfg maxRowsApp = app testMaxRowsCfg diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 2c4778c81..598dce560 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -64,36 +64,32 @@ getEnvVarWithDefault var def = toS <$> getEnv (toS var) `E.catchIOError` const (return $ toS def) _baseCfg :: AppConfig -_baseCfg = -- Connection Settings - let secret = Just $ encodeUtf8 "reallyreallyreallyreallyverysafe" in - AppConfig mempty "postgrest_test_anonymous" Nothing (fromList ["test"]) "localhost" 3000 - -- No user configured Unix Socket - Nothing - -- No user configured Unix Socket file mode (defaults to 660) - (Right 432) - -- db-channel - "pgrst" - -- db-channel-enabled - False - -- Jwt settings - secret False Nothing - -- Connection Modifiers - 10 10 Nothing (Just "test.switch_role") - -- Debug Settings - True - [ ("app.settings.app_host", "localhost") - , ("app.settings.external_api_secret", "0123456789abcdef") - ] - -- Default role claim key - (Right [JSPKey "role"]) - -- Empty db-extra-search-path - [] - -- No root spec override - Nothing - -- Raw output media types - [] - -- Config JWK - (parseSecret <$> secret) +_baseCfg = let secret = Just $ encodeUtf8 "reallyreallyreallyreallyverysafe" in + AppConfig { + configDbUri = mempty + , configAnonRole = "postgrest_test_anonymous" + , configOpenAPIProxyUri = Nothing + , configSchemas = fromList ["test"] + , configHost = "localhost" + , configPort = 3000 + , configSocket = Nothing + , configSocketMode = Right 432 + , configDbChannel = mempty + , configDbChannelEnabled = False + , configJwtSecret = secret + , configJwtSecretIsBase64 = False + , configJwtAudience = Nothing + , configPoolSize = 10 + , configPoolTimeout = 10 + , configMaxRows = Nothing + , configPreReq = Just "test.switch_role" + , configSettings = [ ("app.settings.app_host", "localhost") , ("app.settings.external_api_secret", "0123456789abcdef") ] + , configRoleClaimKey = Right [JSPKey "role"] + , configExtraSearchPath = [] + , configRootSpec = Nothing + , configRawMediaTypes = [] + , configJWKS = parseSecret <$> secret + } testCfg :: Text -> AppConfig testCfg testDbConn = _baseCfg { configDbUri = testDbConn } @@ -156,7 +152,7 @@ testCfgHtmlRawOutput :: Text -> AppConfig testCfgHtmlRawOutput testDbConn = (testCfg testDbConn) { configRawMediaTypes = ["text/html"] } testCfgResponseHeaders :: Text -> AppConfig -testCfgResponseHeaders testDbConn = (testCfg testDbConn) { configReqCheck = Just "custom_headers" } +testCfgResponseHeaders testDbConn = (testCfg testDbConn) { configPreReq = Just "custom_headers" } testMultipleSchemaCfg :: Text -> AppConfig testMultipleSchemaCfg testDbConn = (testCfg testDbConn) { configSchemas = fromList ["v1", "v2"] }