refactor: move logStdout/corsPolicy to Middleware

* remove configQuiet from Config configQuiet was not an end user setting. The logging setup is now an internal parameter. * move proxy uri validation to Private dir
2020-07-13 11:30:16 -05:00
parent 0ff05edd16
commit e272ea47be
10 changed files with 197 additions and 177 deletions
@@ -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
@@ -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")
@@ -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) =
@@ -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
@@ -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
@@ -535,3 +535,6 @@ data ConnectionStatus
  | Connected PgVersion
  | FatalConnectionError Text
  deriving (Eq, Show)
+
+-- | Logging setup
+data LogSetup = LogQuiet | LogStdout deriving (Eq, Show)