diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -2,17 +2,25 @@ module Main where - +import Protolude import PostgREST.App import PostgREST.Config (AppConfig (..), + PgVersion (..), minimumPgVersion, prettyVersion, readOptions) +import PostgREST.Error (prettyUsageError) +import PostgREST.OpenAPI (isMalformedProxyUri) import PostgREST.DbStructure -import Control.Monad -import Data.Monoid ((<>)) -import Data.String.Conversions (cs) +import Control.AutoUpdate +import Data.ByteString.Base64 (decode) +import Data.String (IsString (..)) +import Data.Text (stripPrefix, pack, replace) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Data.Text.IO (hPutStrLn, readFile) +import Data.Function (id) +import Data.Time.Clock.POSIX (getPOSIXTime) import qualified Hasql.Query as H import qualified Hasql.Session as H import qualified Hasql.Decoders as HD @@ -20,25 +28,20 @@ import qualified Hasql.Pool as P import Network.Wai.Handler.Warp import System.IO (BufferMode (..), - hSetBuffering, stderr, - stdin, stdout) -import Web.JWT (secret) + hSetBuffering) import Data.IORef #ifndef mingw32_HOST_OS -import Control.Monad.IO.Class (liftIO) import System.Posix.Signals -import Control.Concurrent (myThreadId) -import Control.Exception.Base (throwTo, AsyncException(..)) #endif isServerVersionSupported :: H.Session Bool isServerVersionSupported = do ver <- H.query () pgVersion - return $ read (cs ver) >= minimumPgVersion + return $ ver >= pgvNum minimumPgVersion where pgVersion = - H.statement "SHOW server_version_num" - HE.unit (HD.singleRow $ HD.value HD.text) True + H.statement "SELECT current_setting('server_version_num')::integer" + HE.unit (HD.singleRow $ HD.value HD.int4) False main :: IO () main = do @@ -46,29 +49,36 @@ hSetBuffering stdin LineBuffering hSetBuffering stderr NoBuffering - conf <- readOptions - let port = configPort conf - pgSettings = cs (configDatabase conf) - appSettings = setPort port - . setServerName (cs $ "postgrest/" <> prettyVersion) + conf <- loadSecretFile =<< readOptions + let host = configHost conf + port = configPort conf + proxy = configProxyUri conf + pgSettings = toS (configDatabase conf) + appSettings = setHost ((fromString . toS) host) + . setPort port + . setServerName (toS $ "postgrest/" <> prettyVersion) $ defaultSettings - unless (secret "secret" /= configJwtSecret conf) $ - putStrLn "WARNING, running in insecure mode, JWT secret is the default value" - Prelude.putStrLn $ "Listening on port " ++ - (show $ configPort conf :: String) + when (isMalformedProxyUri $ toS <$> proxy) $ panic + "Malformed proxy uri, a correct example: https://example.com:8443/basePath" + putStrLn $ ("Listening on port " :: Text) <> show (configPort conf) + pool <- P.acquire (configPool conf, 10, pgSettings) result <- P.use pool $ do supported <- isServerVersionSupported - unless supported $ error ( + unless supported $ panic ( "Cannot run in this PostgreSQL version, PostgREST needs at least " - <> show minimumPgVersion) - getDbStructure (cs $ configSchema conf) + <> pgvName minimumPgVersion) + getDbStructure (toS $ configSchema conf) - refDbStructure <- newIORef $ either (error.show) id result + forM_ (lefts [result]) $ \e -> do + hPutStrLn stderr (prettyUsageError e) + exitFailure + refDbStructure <- newIORef $ either (panic . show) id result + #ifndef mingw32_HOST_OS tid <- myThreadId forM_ [sigINT, sigTERM] $ \sig -> @@ -79,9 +89,39 @@ void $ installHandler sigHUP ( Catch . void . P.use pool $ do - s <- getDbStructure (cs $ configSchema conf) + s <- getDbStructure (toS $ configSchema conf) liftIO $ atomicWriteIORef refDbStructure s ) Nothing #endif - runSettings appSettings $ postgrest conf refDbStructure pool + -- ask for the OS time at most once per second + getTime <- mkAutoUpdate + defaultUpdateSettings { updateAction = getPOSIXTime } + + runSettings appSettings $ postgrest conf refDbStructure pool getTime + +loadSecretFile :: AppConfig -> IO AppConfig +loadSecretFile conf = extractAndTransform mSecret + where + mSecret = decodeUtf8 <$> configJwtSecret conf + isB64 = configJwtSecretIsBase64 conf + + extractAndTransform :: Maybe Text -> IO AppConfig + extractAndTransform Nothing = return conf + extractAndTransform (Just s) = + fmap setSecret $ transformString isB64 =<< + case stripPrefix "@" s of + Nothing -> return s + Just filename -> readFile (toS filename) + + transformString :: Bool -> Text -> IO ByteString + transformString False t = return . encodeUtf8 $ t + transformString True t = + case decode (encodeUtf8 $ replaceUrlChars t) of + Left errMsg -> panic $ pack errMsg + Right bs -> return bs + + setSecret bs = conf { configJwtSecret = Just bs } + + replaceUrlChars = replace "_" "/" . replace "-" "+" . replace "." "=" + diff --git a/postgrest.cabal b/postgrest.cabal --- a/postgrest.cabal +++ b/postgrest.cabal @@ -2,7 +2,7 @@ description: Reads the schema of a PostgreSQL database and creates RESTful routes for the tables and views, supporting all HTTP verbs that security permits. -version: 0.3.2.0 +version: 0.4.0.0 synopsis: REST API for any Postgres database license: MIT license-file: LICENSE @@ -23,168 +23,137 @@ executable postgrest main-is: Main.hs - default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes + default-extensions: OverloadedStrings, QuasiQuotes, NoImplicitPrelude ghc-options: -threaded -rtsopts "-with-rtsopts=-N -I2" default-language: Haskell2010 - build-depends: aeson (>= 0.8 && < 0.10) || (>= 0.11 && < 0.12) - , base >= 4.8 && < 6 - , bytestring - , bytestring-tree-builder == 0.2.7 - , case-insensitive - , cassava - , containers - , contravariant - , errors - , hasql == 0.19.12 - , hasql-pool == 0.4.1 - , hasql-transaction == 0.4.5 - , http-types - , interpolatedstring-perl6 - , jwt - , microlens >= 0.4.2 && < 0.5 - , microlens-aeson >= 2.1.1 && < 2.2 - , mtl - , optparse-applicative >= 0.11 && < 0.13 - , parsec - , postgresql-binary == 0.9.0.1 + build-depends: auto-update + , base + , hasql + , hasql-pool , postgrest - , regex-tdfa - , safe >= 0.3 && < 0.4 - , scientific - , string-conversions + , protolude , text , time - , transformers - , unordered-containers - , vector - , wai >= 3.0.1 - , wai-cors - , wai-extra - , wai-middleware-static >= 0.6.0 - , warp >= 3.1.0 - , HTTP - , Ranged-sets + , warp + , bytestring + , base64-bytestring if !os(windows) - build-depends: unix >= 2.7 && < 3 + build-depends: unix hs-source-dirs: main library default-language: Haskell2010 - default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes + default-extensions: OverloadedStrings, QuasiQuotes, NoImplicitPrelude build-depends: aeson - , base + , ansi-wl-pprint + , base >= 4.8 && < 6 , bytestring , case-insensitive , cassava + , configurator , containers , contravariant - , errors + , either , hasql - , hasql-transaction - , hasql-pool + , hasql-pool == 0.4.1 + , hasql-transaction == 0.5 + , heredoc + , HTTP , http-types + , insert-ordered-containers , interpolatedstring-perl6 , jwt - , microlens - , microlens-aeson - , mtl - , optparse-applicative + , lens + , lens-aeson + , network-uri + , optparse-applicative >= 0.12.0.0 && < 0.13.0.0 , parsec + , protolude + , Ranged-sets == 0.3.0 , regex-tdfa , safe , scientific - , string-conversions + , swagger2 , text , time , unordered-containers , vector - , HTTP - , Ranged-sets - , wai >= 3.0.1 + , wai , wai-cors , wai-extra - , wai-middleware-static >= 0.6.0 - , warp >= 3.1.0 + , wai-middleware-static Other-Modules: Paths_postgrest - Exposed-Modules: PostgREST.App + Exposed-Modules: PostgREST.ApiRequest + , PostgREST.App , PostgREST.Auth , PostgREST.Config + , PostgREST.DbStructure + , PostgREST.DbRequestBuilder , PostgREST.Error , PostgREST.Middleware + , PostgREST.OpenAPI , PostgREST.Parsers - , PostgREST.DbStructure , PostgREST.QueryBuilder , PostgREST.RangeQuery - , PostgREST.ApiRequest , PostgREST.Types hs-source-dirs: src Test-Suite spec Type: exitcode-stdio-1.0 Default-Language: Haskell2010 - default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes + default-extensions: OverloadedStrings, QuasiQuotes, NoImplicitPrelude ghc-options: -threaded -rtsopts -with-rtsopts=-N Hs-Source-Dirs: test Main-Is: Main.hs Other-Modules: Feature.AuthSpec + , Feature.BinaryJwtSecretSpec , Feature.ConcurrentSpec , Feature.CorsSpec , Feature.DeleteSpec , Feature.InsertSpec - , Feature.QuerySpec + , Feature.NoJwtSpec + , Feature.ProxySpec , Feature.QueryLimitedSpec + , Feature.QuerySpec , Feature.RangeSpec + , Feature.SingularSpec , Feature.StructureSpec , Feature.UnicodeSpec , SpecHelper , TestTypes Build-Depends: aeson + , aeson-qq , async + , auto-update , base - , base64-string , bytestring + , base64-bytestring , case-insensitive , cassava , containers , contravariant - , errors , hasql , hasql-pool - , hasql-transaction , heredoc + , hjsonpointer + , hjsonschema , hspec , hspec-wai , hspec-wai-json , http-types - , interpolatedstring-perl6 - , jwt - , microlens - , microlens-aeson + , lens + , lens-aeson , monad-control - , mtl - , optparse-applicative - , parsec , postgrest , process + , protolude , regex-tdfa - , safe - , scientific - , string-conversions - , text , time - , transformers , transformers-base - , unordered-containers - , vector , wai - , wai-cors , wai-extra - , wai-middleware-static - , warp - , HTTP - , Ranged-sets diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -1,32 +1,44 @@ -module PostgREST.ApiRequest where +{-| +Module : PostgREST.ApiRequest +Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest. +-} +module PostgREST.ApiRequest ( ApiRequest(..) + , ApiRequestError(..) + , ContentType(..) + , Action(..) + , Target(..) + , PreferRepresentation (..) + , mutuallyAgreeable + , toHeader + , userApiRequest + , toMime + ) where +import Protolude import qualified Data.Aeson as JSON import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BS (c2w) import qualified Data.ByteString.Lazy as BL import qualified Data.Csv as CSV -import Data.List (find, sortBy) +import qualified Data.List as L +import Data.List (lookup, last) import qualified Data.HashMap.Strict as M import qualified Data.Set as S -import Data.Maybe (fromMaybe, isJust, isNothing, - listToMaybe, fromJust) +import Data.Maybe (fromJust) import Control.Arrow ((***)) -import Control.Monad (join) -import Data.Monoid ((<>)) -import Data.Ord (comparing) -import Data.String.Conversions (cs) import qualified Data.Text as T -import Text.Read (readMaybe) import qualified Data.Vector as V import Network.HTTP.Base (urlEncodeVars) -import Network.HTTP.Types.Header (hAuthorization) +import Network.HTTP.Types.Header (hAuthorization, hContentType, Header) import Network.HTTP.Types.URI (parseSimpleQuery) import Network.Wai (Request (..)) import Network.Wai.Parse (parseHttpAccept) -import PostgREST.RangeQuery (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange) +import PostgREST.RangeQuery (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange, rangeLimit, rangeOffset) +import Data.Ranged.Boundaries import PostgREST.Types (QualifiedIdentifier (..), - Schema, Payload(..), - UniformObjects(..)) -import Data.Ranged.Ranges (singletonRange, rangeIntersection) + Schema, + PayloadJSON(..)) +import Data.Ranged.Ranges (Range(..), rangeIntersection, emptyRange) type RequestBody = BL.ByteString @@ -34,22 +46,40 @@ data Action = ActionCreate | ActionRead | ActionUpdate | ActionDelete | ActionInfo | ActionInvoke - | ActionInappropriate + | ActionInspect deriving Eq -- | The target db object of a user action data Target = TargetIdent QualifiedIdentifier | TargetProc QualifiedIdentifier | TargetRoot - | TargetUnknown [T.Text] + | TargetUnknown [Text] + deriving Eq -- | How to return the inserted data data PreferRepresentation = Full | HeadersOnly | None deriving Eq --- | Enumeration of currently supported content types for --- route responses and upload payloads -data ContentType = ApplicationJSON | TextCSV deriving Eq -instance Show ContentType where - show ApplicationJSON = "application/json; charset=utf-8" - show TextCSV = "text/csv; charset=utf-8" + -- +-- | Enumeration of currently supported response content types +data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI + | CTSingularJSON + | CTAny | CTOther BS.ByteString deriving Eq +data ApiRequestError = ErrorActionInappropriate + | ErrorInvalidBody ByteString + | ErrorInvalidRange + deriving (Show, Eq) + +-- | Convert from ContentType to a full HTTP Header +toHeader :: ContentType -> Header +toHeader ct = (hContentType, toMime ct <> "; charset=utf-8") + +-- | Convert from ContentType to a ByteString representing the mime type +toMime :: ContentType -> ByteString +toMime CTApplicationJSON = "application/json" +toMime CTTextCSV = "text/csv" +toMime CTOpenAPI = "application/openapi+json" +toMime CTSingularJSON = "application/vnd.pgrst.object+json" +toMime CTAny = "*/*" +toMime (CTOther ct) = ct + {-| Describes what the user wants to do. This data type is a translation of the raw elements of an HTTP request into domain @@ -61,163 +91,166 @@ -- | Similar but not identical to HTTP verb, e.g. Create/Invoke both POST iAction :: Action -- | Requested range of rows within response - , iRange :: M.HashMap String NonnegRange + , iRange :: M.HashMap ByteString NonnegRange -- | The target, be it calling a proc or accessing a table , iTarget :: Target - -- | The content type the client most desires (or JSON if undecided) - , iAccepts :: Either BS.ByteString ContentType + -- | Content types the client will accept, [CTAny] if no Accept header + , iAccepts :: [ContentType] -- | Data sent by client and used for mutation actions - , iPayload :: Maybe Payload + , iPayload :: Maybe PayloadJSON -- | If client wants created items echoed back , iPreferRepresentation :: PreferRepresentation - -- | If client wants first row as raw object - , iPreferSingular :: Bool + -- | Pass all parameters as a single json object to a stored procedure + , iPreferSingleObjectParameter :: Bool -- | Whether the client wants a result count (slower) , iPreferCount :: Bool -- | Filters on the result ("id", "eq.10") - , iFilters :: [(String, String)] + , iFilters :: [(Text, Text)] -- | &select parameter used to shape the response - , iSelect :: String + , iSelect :: Text -- | &order parameters for each level - , iOrder :: [(String,String)] + , iOrder :: [(Text, Text)] -- | Alphabetized (canonical) request query string for response URLs - , iCanonicalQS :: String + , iCanonicalQS :: ByteString -- | JSON Web Token - , iJWT :: T.Text + , iJWT :: Text } -- | Examines HTTP request and translates it into user intent. -userApiRequest :: Schema -> Request -> RequestBody -> ApiRequest -userApiRequest schema req reqBody = - let action = - if isTargetingProc - then - if method == "POST" - then ActionInvoke - else ActionInappropriate - else - case method of - "GET" -> ActionRead - "POST" -> ActionCreate - "PATCH" -> ActionUpdate - "DELETE" -> ActionDelete - "OPTIONS" -> ActionInfo - _ -> ActionInappropriate - target = case path of - [] -> TargetRoot - [table] -> TargetIdent - $ QualifiedIdentifier schema table - ["rpc", proc] -> TargetProc - $ QualifiedIdentifier schema proc - other -> TargetUnknown other - payload = case pickContentType (lookupHeader "content-type") of - Right ApplicationJSON -> - either (PayloadParseError . cs) - (\val -> case ensureUniform (pluralize val) of - Nothing -> PayloadParseError "All object keys must match" - Just json -> PayloadJSON json) - (JSON.eitherDecode reqBody) - Right TextCSV -> - either (PayloadParseError . cs) - (\val -> case ensureUniform (csvToJson val) of - Nothing -> PayloadParseError "All lines must have same number of fields" - Just json -> PayloadJSON json) - (CSV.decodeByName reqBody) - -- This is a Left value because form-urlencoded is not a content - -- type which we ever use for responses, only something we handle - -- just this once for requests - Left "application/x-www-form-urlencoded" -> - PayloadJSON . UniformObjects . V.singleton . M.fromList - . map (cs *** JSON.String . cs) . parseSimpleQuery - $ cs reqBody - Left accept -> - PayloadParseError $ - "Content-type not acceptable: " <> accept - relevantPayload = case action of - ActionCreate -> Just payload - ActionUpdate -> Just payload - ActionInvoke -> Just payload - _ -> Nothing in - - ApiRequest { - iAction = action - , iTarget = target - , iRange = M.insert "limit" (rangeIntersection headerRange urlRange) $ - M.fromList [ (cs k, restrictRange (readMaybe =<< v) allRange) | (k,v) <- qParams, isJust v, endingIn ["limit"] k ] - , iAccepts = pickContentType $ lookupHeader "accept" - , iPayload = relevantPayload - , iPreferRepresentation = representation - , iPreferSingular = singular - , iPreferCount = not $ singular || hasPrefer "count=none" - , iFilters = [ (cs k, fromJust v) | (k,v) <- qParams, isJust v, k /= "select", k /= "offset", not (endingIn ["order", "limit"] k) ] - , iSelect = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams - , iOrder = [(cs k, fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ] - , iCanonicalQS = urlEncodeVars - . sortBy (comparing fst) - . map (join (***) cs) - . parseSimpleQuery - $ rawQueryString req - , iJWT = tokenStr - } - +userApiRequest :: Schema -> Request -> RequestBody -> Either ApiRequestError ApiRequest +userApiRequest schema req reqBody + | isTargetingProc && method /= "POST" = Left ErrorActionInappropriate + | topLevelRange == emptyRange = Left ErrorInvalidRange + | shouldParsePayload && isLeft payload = either (Left . ErrorInvalidBody . toS) undefined payload + | otherwise = Right ApiRequest { + iAction = action + , iTarget = target + , iRange = ranges + , iAccepts = fromMaybe [CTAny] $ + map decodeContentType . parseHttpAccept <$> lookupHeader "accept" + , iPayload = relevantPayload + , iPreferRepresentation = representation + , iPreferSingleObjectParameter = singleObject + , iPreferCount = hasPrefer "count=exact" + , iFilters = [ (toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, k /= "select", not (endingIn ["order", "limit", "offset"] k) ] + , iSelect = toS $ fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams + , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ] + , iCanonicalQS = toS $ urlEncodeVars + . L.sortBy (comparing fst) + . map (join (***) toS) + . parseSimpleQuery + $ rawQueryString req + , iJWT = tokenStr + } where + isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path + payload = + case decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type" of + CTApplicationJSON -> + either Left (\val -> case ensureUniform (pluralize val) of + Nothing -> Left "All object keys must match" + Just json -> Right json) (JSON.eitherDecode reqBody) + CTTextCSV -> + either Left (\val -> case ensureUniform (csvToJson val) of + Nothing -> Left "All lines must have same number of fields" + Just json -> Right json) (CSV.decodeByName reqBody) + CTOther "application/x-www-form-urlencoded" -> + Right . PayloadJSON . V.singleton . M.fromList + . map (toS *** JSON.String . toS) . parseSimpleQuery + $ toS reqBody + ct -> + Left $ toS $ "Content-Type not acceptable: " <> toMime ct + topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges + action = case method of + "GET" -> if target == TargetRoot + then ActionInspect + else ActionRead + "POST" -> if isTargetingProc + then ActionInvoke + else ActionCreate + "PATCH" -> ActionUpdate + "DELETE" -> ActionDelete + "OPTIONS" -> ActionInfo + _ -> ActionInspect + target = case path of + [] -> TargetRoot + [table] -> TargetIdent + $ QualifiedIdentifier schema table + ["rpc", proc] -> TargetProc + $ QualifiedIdentifier schema proc + other -> TargetUnknown other + shouldParsePayload = action `elem` [ActionCreate, ActionUpdate, ActionInvoke] + relevantPayload = if shouldParsePayload + then rightToMaybe payload + else Nothing path = pathInfo req method = requestMethod req - isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path hdrs = requestHeaders req - qParams = [(cs k, cs <$> v)|(k,v) <- queryString req] + qParams = [(toS k, v)|(k,v) <- queryString req] lookupHeader = flip lookup hdrs - hasPrefer :: T.Text -> Bool + hasPrefer :: Text -> Bool hasPrefer val = any (\(h,v) -> h == "Prefer" && val `elem` split v) hdrs where - split :: BS.ByteString -> [T.Text] - split = map T.strip . T.split (==';') . cs - singular = hasPrefer "plurality=singular" + split :: BS.ByteString -> [Text] + split = map T.strip . T.split (==',') . toS + singleObject = hasPrefer "params=single-object" representation | hasPrefer "return=representation" = Full | hasPrefer "return=minimal" = None | otherwise = HeadersOnly auth = fromMaybe "" $ lookupHeader hAuthorization - tokenStr = case T.split (== ' ') (cs auth) of + tokenStr = case T.split (== ' ') (toS auth) of ("Bearer" : t : _) -> t _ -> "" - endingIn:: [T.Text] -> T.Text -> Bool + endingIn:: [Text] -> Text -> Bool endingIn xx key = lastWord `elem` xx where lastWord = last $ T.split (=='.') key - headerRange = if singular then singletonRange 0 else rangeRequested hdrs - urlOffsetRange = rangeGeq . fromMaybe (0::Integer) $ - readMaybe =<< join (lookup "offset" qParams) - urlRange = restrictRange - (readMaybe =<< join (lookup "limit" qParams)) - urlOffsetRange + headerRange = rangeRequested hdrs + replaceLast x s = T.intercalate "." $ L.init (T.split (=='.') s) ++ [x] + limitParams :: M.HashMap ByteString NonnegRange + limitParams = M.fromList [(toS (replaceLast "limit" k), restrictRange (readMaybe =<< (toS <$> v)) allRange) | (k,v) <- qParams, isJust v, endingIn ["limit"] k] + offsetParams :: M.HashMap ByteString NonnegRange + offsetParams = M.fromList [(toS (replaceLast "limit" k), fromMaybe allRange (rangeGeq <$> (readMaybe =<< (toS <$> v)))) | (k,v) <- qParams, isJust v, endingIn ["offset"] k] --- PRIVATE --------------------------------------------------------------- + urlRange = M.unionWith f limitParams offsetParams + where + f rl ro = Range (BoundaryBelow o) (BoundaryAbove $ o + l - 1) + where + l = fromMaybe 0 $ rangeLimit rl + o = rangeOffset ro + ranges = M.insert "limit" (rangeIntersection headerRange (fromMaybe allRange (M.lookup "limit" urlRange))) urlRange {-| - Picks a preferred content type from an Accept header (or from - Content-Type as a degenerate case). + Find the best match from a list of content types accepted by the + client in order of decreasing preference and a list of types + producible by the server. If there is no match but the client + accepts */* then return the top server pick. +-} +mutuallyAgreeable :: [ContentType] -> [ContentType] -> Maybe ContentType +mutuallyAgreeable sProduces cAccepts = + let exact = listToMaybe $ L.intersect cAccepts sProduces in + if isNothing exact && CTAny `elem` cAccepts + then listToMaybe sProduces + else exact - For example - text/csv -> TextCSV - */* -> ApplicationJSON - text/csv, application/json -> TextCSV - application/json, text/csv -> ApplicationJSON +-- PRIVATE --------------------------------------------------------------- + +{-| + Warning: discards MIME parameters -} -pickContentType :: Maybe BS.ByteString -> Either BS.ByteString ContentType -pickContentType accept - | isNothing accept || has ctAll || has ctJson = Right ApplicationJSON - | has ctCsv = Right TextCSV - | otherwise = Left accept' - where - ctAll = "*/*" - ctCsv = "text/csv" - ctJson = "application/json" - Just accept' = accept - findInAccept = flip find $ parseHttpAccept accept' - has = isJust . findInAccept . BS.isPrefixOf +decodeContentType :: BS.ByteString -> ContentType +decodeContentType ct = + case BS.takeWhile (/= BS.c2w ';') ct of + "application/json" -> CTApplicationJSON + "text/csv" -> CTTextCSV + "application/openapi+json" -> CTOpenAPI + "application/vnd.pgrst.object+json" -> CTSingularJSON + "application/vnd.pgrst.object" -> CTSingularJSON + "*/*" -> CTAny + ct' -> CTOther ct' -type CsvData = V.Vector (M.HashMap T.Text BL.ByteString) +type CsvData = V.Vector (M.HashMap Text BL.ByteString) {-| Converts CSV like @@ -239,7 +272,7 @@ M.map (\str -> if str == "NULL" then JSON.Null - else JSON.String $ cs str + else JSON.String $ toS str ) -- | Convert {foo} to [{foo}], leave arrays unchanged @@ -250,8 +283,8 @@ pluralize _ = V.empty -- | Test that Array contains only Objects having the same keys --- and if so mark it as UniformObjects -ensureUniform :: JSON.Array -> Maybe UniformObjects +-- and if so mark it as PayloadJSON +ensureUniform :: JSON.Array -> Maybe PayloadJSON ensureUniform arr = let objs :: V.Vector JSON.Object objs = foldr -- filter non-objects, map to raw objects @@ -264,5 +297,5 @@ areKeysUniform = all (==canonicalKeys) keysPerObj in if (V.length objs == V.length arr) && areKeysUniform - then Just (UniformObjects objs) + then Just (PayloadJSON objs) else Nothing diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -7,82 +7,76 @@ ) where import Control.Applicative -import Data.Bifunctor (first) -import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Char8 as BS import Data.IORef (IORef, readIORef) -import Data.List (find, delete) -import Data.Maybe (fromMaybe, fromJust, mapMaybe) -import Data.Ranged.Ranges (emptyRange) -import Data.String.Conversions (cs) -import Data.Text (Text, replace, strip) -import Data.Tree - -import qualified Hasql.Pool as P -import qualified Hasql.Transaction as HT +import Data.Text (intercalate) +import Data.Time.Clock.POSIX (POSIXTime) -import Text.Parsec.Error -import Text.ParserCombinators.Parsec (parse) +import qualified Hasql.Pool as P +import qualified Hasql.Transaction as HT +import qualified Hasql.Transaction.Sessions as HT import Network.HTTP.Types.Header import Network.HTTP.Types.Status -import Network.HTTP.Types.URI (renderSimpleQuery) +import Network.HTTP.Types.URI (renderSimpleQuery) import Network.Wai import Network.Wai.Middleware.RequestLogger (logStdout) +import Web.JWT (binarySecret) -import Data.Aeson -import Data.Aeson.Types (emptyArray) -import Data.Monoid -import Data.Time.Clock.POSIX (getPOSIXTime) import qualified Data.Vector as V import qualified Hasql.Transaction as H import qualified Data.HashMap.Strict as M -import PostgREST.ApiRequest (ApiRequest(..), ContentType(..) - , Action(..), Target(..) - , PreferRepresentation (..) - , userApiRequest) -import PostgREST.Auth (tokenJWT, jwtClaims, containsRole) +import PostgREST.ApiRequest ( ApiRequest(..), ContentType(..) + , Action(..), Target(..) + , PreferRepresentation (..) + , mutuallyAgreeable + , toHeader + , userApiRequest + , toMime + ) +import PostgREST.Auth (jwtClaims, containsRole) import PostgREST.Config (AppConfig (..)) import PostgREST.DbStructure -import PostgREST.Error (errResponse, pgErrResponse) -import PostgREST.Parsers -import PostgREST.RangeQuery (NonnegRange, allRange, rangeOffset, restrictRange) +import PostgREST.DbRequestBuilder(readRequest, mutateRequest) +import PostgREST.Error (errResponse, pgErrResponse, apiRequestErrResponse, singularityError) +import PostgREST.RangeQuery (allRange, rangeOffset) import PostgREST.Middleware import PostgREST.QueryBuilder ( callProc - , addJoinConditions - , sourceCTEName , requestToQuery , requestToCountQuery - , addRelations , createReadStatement , createWriteStatement , ResultsWithCount ) import PostgREST.Types - -import Prelude +import PostgREST.OpenAPI +import Data.Function (id) +import Protolude hiding (intercalate, Proxy) -postgrest :: AppConfig -> IORef DbStructure -> P.Pool -> Application -postgrest conf refDbStructure pool = +postgrest :: AppConfig -> IORef DbStructure -> P.Pool -> IO POSIXTime -> + Application +postgrest conf refDbStructure pool getTime = let middle = (if configQuiet conf then id else logStdout) . defaultMiddle in middle $ \ req respond -> do - time <- getPOSIXTime + time <- getTime body <- strictRequestBody req dbStructure <- readIORef refDbStructure - let schema = cs $ configSchema conf - apiRequest = userApiRequest schema req body - eClaims = jwtClaims (configJwtSecret conf) (iJWT apiRequest) time - authed = containsRole eClaims - handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest - txMode = transactionMode $ iAction apiRequest - - resp <- either (pgErrResponse authed) id <$> P.use pool - (HT.run handleReq HT.ReadCommitted txMode) - respond resp + response <- case userApiRequest (configSchema conf) req body of + Left err -> return $ apiRequestErrResponse err + Right apiRequest -> do + let jwtSecret = binarySecret <$> configJwtSecret conf + eClaims = jwtClaims jwtSecret (iJWT apiRequest) time + authed = containsRole eClaims + handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest + txMode = transactionMode $ iAction apiRequest + response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq + return $ either (pgErrResponse authed) identity response + respond response transactionMode :: Action -> H.Mode transactionMode ActionRead = HT.Read @@ -91,157 +85,205 @@ app :: DbStructure -> AppConfig -> ApiRequest -> H.Transaction Response app dbStructure conf apiRequest = - let - -- TODO: blow up for Left values (there is a middleware that checks the headers) - contentType = either (const ApplicationJSON) id (iAccepts apiRequest) - contentTypeH = (hContentType, cs $ show contentType) in - - case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of + case responseContentTypeOrError (iAccepts apiRequest) (iAction apiRequest) of + Left errorResponse -> return errorResponse + Right contentType -> + case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of - (ActionRead, TargetIdent qi, Nothing) -> - case readSqlParts of - Left e -> return $ responseLBS status400 [jsonH] $ cs e - Right (q, cq) -> do - let singular = iPreferSingular apiRequest - stm = createReadStatement q cq singular - shouldCount (contentType == TextCSV) - respondToRange $ do - row <- H.query () stm - let (tableTotal, queryTotal, _ , body) = row - if singular - then return $ if queryTotal <= 0 - then responseLBS status404 [] "" - else responseLBS status200 [contentTypeH] (cs body) - else do - let (status, contentRange) = rangeHeader queryTotal tableTotal + (ActionRead, TargetIdent qi, Nothing) -> + case readSqlParts of + Left errorResponse -> return errorResponse + Right (q, cq) -> do + let stm = createReadStatement q cq (contentType == CTSingularJSON) shouldCount (contentType == CTTextCSV) + row <- H.query () stm + let (tableTotal, queryTotal, _ , body) = row + (status, contentRange) = rangeHeader queryTotal tableTotal canonical = iCanonicalQS apiRequest - return $ responseLBS status - [contentTypeH, contentRange, - ("Content-Location", - "/" <> cs (qiName qi) <> - if Prelude.null canonical then "" else "?" <> cs canonical - ) - ] (cs body) - - (ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table), - Just payload@(PayloadJSON uniform@(UniformObjects rows))) -> - case mutateSqlParts of - Left e -> return $ responseLBS status400 [jsonH] $ cs e - Right (sq,mq) -> do - let isSingle = (==1) $ V.length rows - let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself? - let stm = createWriteStatement qi sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == TextCSV) payload - row <- H.query uniform stm - let (_, _, fs, body) = extractQueryResult row - header = - if null fs then [] - else [(hLocation, "/" <> cs table <> renderLocationFields fs)] + return $ + if contentType == CTSingularJSON && queryTotal /= 1 + then singularityError (toInteger queryTotal) + else responseLBS status + [toHeader contentType, contentRange, + ("Content-Location", + "/" <> toS (qiName qi) <> + if BS.null canonical then "" else "?" <> toS canonical + ) + ] (toS body) - return $ if iPreferRepresentation apiRequest == Full - then responseLBS status201 (contentTypeH : header) (cs body) - else responseLBS status201 header "" + (ActionCreate, TargetIdent (QualifiedIdentifier _ table), Just payload@(PayloadJSON rows)) -> + case mutateSqlParts of + Left errorResponse -> return errorResponse + Right (sq, mq) -> do + let isSingle = (==1) $ V.length rows + if contentType == CTSingularJSON + && not isSingle + && iPreferRepresentation apiRequest == Full + then return $ singularityError (toInteger $ V.length rows) + else do + let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself? + stm = createWriteStatement sq mq + (contentType == CTSingularJSON) isSingle + (contentType == CTTextCSV) (iPreferRepresentation apiRequest) + pKeys + row <- H.query payload stm + let (_, _, fs, body) = extractQueryResult row + headers = catMaybes [ + if null fs + then Nothing + else Just (hLocation, "/" <> toS table <> renderLocationFields fs) + , if iPreferRepresentation apiRequest == Full + then Just $ toHeader contentType + else Nothing + , Just . contentRangeH 1 0 $ + toInteger <$> if shouldCount then Just (V.length rows) else Nothing + ] - (ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON uniform)) -> - case mutateSqlParts of - Left e -> return $ responseLBS status400 [jsonH] $ cs e - Right (sq,mq) -> do - let stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) payload - row <- H.query uniform stm - let (_, queryTotal, _, body) = extractQueryResult row - r = contentRangeH 0 (toInteger $ queryTotal-1) (toInteger <$> Just queryTotal) - s = case () of _ | queryTotal == 0 -> status404 - | iPreferRepresentation apiRequest == Full -> status200 - | otherwise -> status204 - return $ if iPreferRepresentation apiRequest == Full - then responseLBS s [contentTypeH, r] (cs body) - else responseLBS s [r] "" + return . responseLBS status201 headers $ + if iPreferRepresentation apiRequest == Full + then toS body else "" - (ActionDelete, TargetIdent qi, Nothing) -> - case mutateSqlParts of - Left e -> return $ responseLBS status400 [jsonH] $ cs e - Right (sq,mq) -> do - let emptyUniform = UniformObjects V.empty - fakeload = PayloadJSON emptyUniform - stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) fakeload - row <- H.query emptyUniform stm - let (_, queryTotal, _, body) = extractQueryResult row - r = contentRangeH 1 0 (toInteger <$> Just queryTotal) - return $ if queryTotal == 0 - then notFound - else if iPreferRepresentation apiRequest == Full - then responseLBS status200 [contentTypeH, r] (cs body) - else responseLBS status204 [r] "" + (ActionUpdate, TargetIdent _, Just payload) -> + case mutateSqlParts of + Left errorResponse -> return errorResponse + Right (sq, mq) -> do + let stm = createWriteStatement sq mq + (contentType == CTSingularJSON) False (contentType == CTTextCSV) + (iPreferRepresentation apiRequest) [] + row <- H.query payload stm + let (_, queryTotal, _, body) = extractQueryResult row + if contentType == CTSingularJSON + && queryTotal /= 1 + && iPreferRepresentation apiRequest == Full + then do + HT.condemn + return $ singularityError (toInteger queryTotal) + else do + let r = contentRangeH 0 (toInteger $ queryTotal-1) + (toInteger <$> if shouldCount then Just queryTotal else Nothing) + s = if iPreferRepresentation apiRequest == Full + then status200 + else status204 + return $ if iPreferRepresentation apiRequest == Full + then responseLBS s [toHeader contentType, r] (toS body) + else responseLBS s [r] "" - (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) -> - let mTable = find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure) in - case mTable of - Nothing -> return notFound - Just table -> - let cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure - pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys - body = encode (TableOptions cols pkeys) - filterCol :: Schema -> TableName -> Column -> Bool - filterCol sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb - filterCol _ _ _ = False - acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in - return $ responseLBS status200 [jsonH, allOrigins, acceptH] $ cs body + (ActionDelete, TargetIdent _, Nothing) -> + case mutateSqlParts of + Left errorResponse -> return errorResponse + Right (sq, mq) -> do + let emptyPayload = PayloadJSON V.empty + stm = createWriteStatement sq mq + (contentType == CTSingularJSON) False + (contentType == CTTextCSV) + (iPreferRepresentation apiRequest) [] + row <- H.query emptyPayload stm + let (_, queryTotal, _, body) = extractQueryResult row + r = contentRangeH 1 0 $ + toInteger <$> if shouldCount then Just queryTotal else Nothing + if contentType == CTSingularJSON + && queryTotal /= 1 + && iPreferRepresentation apiRequest == Full + then do + HT.condemn + return $ singularityError (toInteger queryTotal) + else + return $ if iPreferRepresentation apiRequest == Full + then responseLBS status200 [toHeader contentType, r] (toS body) + else responseLBS status204 [r] "" - (ActionInvoke, TargetProc qi, - Just (PayloadJSON (UniformObjects payload))) -> do - exists <- H.query qi doesProcExist - if exists - then do - let p = V.head payload - jwtSecret = configJwtSecret conf - respondToRange $ do - row <- H.query () (callProc qi p topLevelRange shouldCount) - returnJWT <- H.query qi doesProcReturnJWT - let (tableTotal, queryTotal, body) = fromMaybe (Just 0, 0, emptyArray) row - (status, contentRange) = rangeHeader queryTotal tableTotal - in - return $ responseLBS status [jsonH, contentRange] - (if returnJWT - then "{\"token\":\"" <> cs (tokenJWT jwtSecret body) <> "\"}" - else cs $ encode body) - else return notFound + (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) -> + let mTable = find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure) in + case mTable of + Nothing -> return notFound + Just table -> + let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in + return $ responseLBS status200 [allOrigins, acceptH] "" - (ActionRead, TargetRoot, Nothing) -> do - body <- encode <$> H.query schema accessibleTables - return $ responseLBS status200 [jsonH] $ cs body + (ActionInvoke, TargetProc qi, Just (PayloadJSON payload)) -> + case readSqlParts of + Left errorResponse -> return errorResponse + Right (q, cq) -> do + let p = V.head payload + singular = contentType == CTSingularJSON + paramsAsSingleObject = iPreferSingleObjectParameter apiRequest + row <- H.query () (callProc qi p q cq topLevelRange shouldCount singular paramsAsSingleObject) + let (tableTotal, queryTotal, body) = + fromMaybe (Just 0, 0, "[]") row + (status, contentRange) = rangeHeader queryTotal tableTotal + if singular && queryTotal /= 1 + then do + HT.condemn + return $ singularityError (toInteger queryTotal) + else return $ responseLBS status [jsonH, contentRange] (toS body) - (ActionInappropriate, _, _) -> return $ responseLBS status405 [] "" + (ActionInspect, TargetRoot, Nothing) -> do + let host = configHost conf + port = toInteger $ configPort conf + proxy = pickProxy $ toS <$> configProxyUri conf + uri Nothing = ("http", host, port, "/") + uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b) + uri' = uri proxy + encodeApi ti = encodeOpenAPI (map snd $ dbProcs dbStructure) ti uri' + body <- encodeApi . toTableInfo <$> H.query schema accessibleTables + return $ responseLBS status200 [toHeader CTOpenAPI] $ toS body - (_, _, Just (PayloadParseError e)) -> - return $ responseLBS status400 [jsonH] $ - cs (formatGeneralError "Cannot parse request payload" (cs e)) + _ -> return notFound - (_, TargetUnknown _, _) -> return notFound + where + toTableInfo :: [Table] -> [(Table, [Column], [Text])] + toTableInfo = map (\t -> + let tSchema = tableSchema t + tTable = tableName t + cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure + pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys + in (t, cols, pkeys)) + notFound = responseLBS status404 [] "" + filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk + filterCol :: Schema -> TableName -> Column -> Bool + filterCol sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb + filterCol _ _ _ = False + allPrKeys = dbPrimaryKeys dbStructure + allOrigins = ("Access-Control-Allow-Origin", "*") :: Header + jsonH = toHeader CTApplicationJSON + shouldCount = iPreferCount apiRequest + schema = toS $ configSchema conf + topLevelRange = fromMaybe allRange $ M.lookup "limit" $ iRange apiRequest + rangeHeader queryTotal tableTotal = + let lower = rangeOffset topLevelRange + upper = lower + toInteger queryTotal - 1 + contentRange = contentRangeH lower upper (toInteger <$> tableTotal) + status = rangeStatus lower upper (toInteger <$> tableTotal) + in (status, contentRange) - (_, _, _) -> return notFound + mapSnd f (a, b) = (a, f b) + readReq = readRequest (configMaxRows conf) (dbRelations dbStructure) (map (mapSnd pdReturnType) $ dbProcs dbStructure) apiRequest + readDbRequest = DbRead <$> readReq + mutateDbRequest = DbMutate <$> (mutateRequest apiRequest =<< readReq) + selectQuery = requestToQuery schema False <$> readDbRequest + mutateQuery = requestToQuery schema False <$> mutateDbRequest + countQuery = requestToCountQuery schema <$> readDbRequest + readSqlParts = (,) <$> selectQuery <*> countQuery + mutateSqlParts = (,) <$> selectQuery <*> mutateQuery - where - notFound = responseLBS status404 [] "" - filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk - allPrKeys = dbPrimaryKeys dbStructure - allOrigins = ("Access-Control-Allow-Origin", "*") :: Header - schema = cs $ configSchema conf - shouldCount = iPreferCount apiRequest - topLevelRange = fromMaybe allRange $ M.lookup "limit" $ iRange apiRequest - readDbRequest = DbRead <$> buildReadRequest (configMaxRows conf) (dbRelations dbStructure) apiRequest - mutateDbRequest = DbMutate <$> buildMutateRequest apiRequest - selectQuery = requestToQuery schema <$> readDbRequest - countQuery = requestToCountQuery schema <$> readDbRequest - mutateQuery = requestToQuery schema <$> mutateDbRequest - readSqlParts = (,) <$> selectQuery <*> countQuery - mutateSqlParts = (,) <$> selectQuery <*> mutateQuery - respondToRange response = if topLevelRange == emptyRange - then return $ errResponse status416 "HTTP Range error" - else response - rangeHeader queryTotal tableTotal = let frm = rangeOffset topLevelRange - to = frm + toInteger queryTotal - 1 - contentRange = contentRangeH frm to (toInteger <$> tableTotal) - status = rangeStatus frm to (toInteger <$> tableTotal) - in (status, contentRange) +responseContentTypeOrError :: [ContentType] -> Action -> Either Response ContentType +responseContentTypeOrError accepts action = serves contentTypesForRequest accepts + where + contentTypesForRequest = + case action of + ActionRead -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] + ActionCreate -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] + ActionUpdate -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] + ActionDelete -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] + ActionInvoke -> [CTApplicationJSON, CTSingularJSON] + ActionInspect -> [CTOpenAPI] + ActionInfo -> [CTTextCSV] + serves sProduces cAccepts = + case mutuallyAgreeable sProduces cAccepts of + Nothing -> do + let failed = intercalate ", " $ map (toS . toMime) cAccepts + Left $ errResponse status415 $ + "None of these Content-Types are available: " <> failed + Just ct -> Right ct splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString) splitKeyValue kv = (k, BS.tail v) @@ -253,186 +295,22 @@ rangeStatus :: Integer -> Integer -> Maybe Integer -> Status rangeStatus _ _ Nothing = status200 -rangeStatus frm to (Just total) - | frm > total = status416 - | (1 + to - frm) < total = status206 +rangeStatus lower upper (Just total) + | lower > total = status416 + | (1 + upper - lower) < total = status206 | otherwise = status200 contentRangeH :: Integer -> Integer -> Maybe Integer -> Header -contentRangeH frm to total = - ("Content-Range", cs headerValue) +contentRangeH lower upper total = + ("Content-Range", headerValue) where headerValue = rangeString <> "/" <> totalString rangeString - | totalNotZero && fromInRange = show frm <> "-" <> cs (show to) + | totalNotZero && fromInRange = show lower <> "-" <> show upper | otherwise = "*" totalString = fromMaybe "*" (show <$> total) totalNotZero = fromMaybe True ((/=) 0 <$> total) - fromInRange = frm <= to - -jsonH :: Header -jsonH = (hContentType, "application/json; charset=utf-8") - -formatRelationError :: Text -> Text -formatRelationError = formatGeneralError - "could not find foreign keys between these entities" - -formatParserError :: ParseError -> Text -formatParserError e = formatGeneralError message details - where - message = cs $ show (errorPos e) - details = strip $ replace "\n" " " $ cs - $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e) - -formatGeneralError :: Text -> Text -> Text -formatGeneralError message details = cs $ encode $ object [ - "message" .= message, - "details" .= details] - -augumentRequestWithJoin :: Schema -> [Relation] -> ReadRequest -> Either Text ReadRequest -augumentRequestWithJoin schema allRels request = - (first formatRelationError . addRelations schema allRels Nothing) request - >>= addJoinConditions schema - -addFiltersOrdersRanges :: ApiRequest -> Either ParseError (ReadRequest -> ReadRequest) -addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [ - flip (foldr addFilter) <$> filters, - flip (foldr addOrder) <$> orders, - flip (foldr addRange) <$> ranges - ] - {- - The esence of what is going on above is that we are composing tree functions - of type (ReadRequest->ReadRequest) that are in (Either ParseError a) context - -} - where - filters :: Either ParseError [(Path, Filter)] - filters = mapM pRequestFilter flts - where - action = iAction apiRequest - flts = if action == ActionRead - then iFilters apiRequest - else filter (( '.' `elem` ) . fst) $ iFilters apiRequest -- there can be no filters on the root table whre we are doing insert/update - orders :: Either ParseError [(Path, [OrderTerm])] - orders = mapM pRequestOrder $ iOrder apiRequest - ranges :: Either ParseError [(Path, NonnegRange)] - ranges = mapM pRequestRange $ M.toList $ iRange apiRequest - -treeRestrictRange :: Maybe Integer -> ReadRequest -> Either Text ReadRequest -treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` request - where - nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode - nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i) - -buildReadRequest :: Maybe Integer -> [Relation] -> ApiRequest -> Either Text ReadRequest -buildReadRequest maxRows allRels apiRequest = - treeRestrictRange maxRows =<< - augumentRequestWithJoin schema relations =<< - first formatParserError readRequest - where - (schema, rootTableName) = fromJust $ -- Make it safe - let target = iTarget apiRequest in - case target of - (TargetIdent (QualifiedIdentifier s t) ) -> Just (s, t) - _ -> Nothing - - action :: Action - action = iAction apiRequest - - readRequest :: Either ParseError ReadRequest - readRequest = addFiltersOrdersRanges apiRequest <*> - parse (pRequestSelect rootName) ("failed to parse select parameter <<"++selStr++">>") selStr - where - selStr = iSelect apiRequest - rootName = if action == ActionRead - then rootTableName - else sourceCTEName - - relations :: [Relation] - relations = case action of - ActionCreate -> fakeSourceRelations ++ allRels - ActionUpdate -> fakeSourceRelations ++ allRels - ActionDelete -> fakeSourceRelations ++ allRels - _ -> allRels - where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation - -buildMutateRequest :: ApiRequest -> Either Text MutateRequest -buildMutateRequest apiRequest = case action of - ActionCreate -> Insert rootTableName <$> pure payload - ActionUpdate -> Update rootTableName <$> pure payload <*> filters - ActionDelete -> Delete rootTableName <$> filters - _ -> Left "Unsupported HTTP verb" - where - action = iAction apiRequest - payload = fromJust $ iPayload apiRequest - rootTableName = -- TODO: Make it safe - let target = iTarget apiRequest in - case target of - (TargetIdent (QualifiedIdentifier _ t) ) -> t - _ -> undefined - filters = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters - where mutateFilters = filter (not . ( '.' `elem` ) . fst) $ iFilters apiRequest -- update/delete filters can be only on the root table - -addFilterToNode :: Filter -> ReadRequest -> ReadRequest -addFilterToNode flt (Node (q@Select {flt_=flts}, i) f) = Node (q {flt_=flt:flts}, i) f - -addFilter :: (Path, Filter) -> ReadRequest -> ReadRequest -addFilter = addProperty addFilterToNode - -addOrderToNode :: [OrderTerm] -> ReadRequest -> ReadRequest -addOrderToNode o (Node (q,i) f) = Node (q{order=Just o}, i) f - -addOrder :: (Path, [OrderTerm]) -> ReadRequest -> ReadRequest -addOrder = addProperty addOrderToNode - -addRangeToNode :: NonnegRange -> ReadRequest -> ReadRequest -addRangeToNode r (Node (q,i) f) = Node (q{range_=r}, i) f - -addRange :: (Path, NonnegRange) -> ReadRequest -> ReadRequest -addRange = addProperty addRangeToNode - -addProperty :: (a -> ReadRequest -> ReadRequest) -> (Path, a) -> ReadRequest -> ReadRequest -addProperty f ([], a) n = f a n -addProperty f (path, a) (Node rn forest) = - case targetNode of - Nothing -> Node rn forest -- the property is silenty dropped in the Request does not contain the required path - Just tn -> Node rn (addProperty f (remainingPath, a) tn:restForest) - where - targetNodeName:remainingPath = path - (targetNode,restForest) = splitForest targetNodeName forest - splitForest :: NodeName -> Forest ReadNode -> (Maybe ReadRequest, Forest ReadNode) - splitForest name forst = - case maybeNode of - Nothing -> (Nothing,forest) - Just node -> (Just node, delete node forest) - where - maybeNode :: Maybe ReadRequest - maybeNode = find fnd forst - where - fnd :: ReadRequest -> Bool - fnd (Node (_,(n,_,_)) _) = n == name - --- in a relation where one of the tables mathces "TableName" --- replace the name to that table with pg_source --- this "fake" relations is needed so that in a mutate query --- we can look a the "returning *" part which is wrapped with a "with" --- as just another table that has relations with other tables -toSourceRelation :: TableName -> Relation -> Maybe Relation -toSourceRelation mt r@(Relation t _ ft _ _ rt _ _) - | mt == tableName t = Just $ r {relTable=t {tableName=sourceCTEName}} - | mt == tableName ft = Just $ r {relFTable=t {tableName=sourceCTEName}} - | Just mt == (tableName <$> rt) = Just $ r {relLTable=(\tbl -> tbl {tableName=sourceCTEName}) <$> rt} - | otherwise = Nothing - -data TableOptions = TableOptions { - tblOptcolumns :: [Column] -, tblOptpkey :: [Text] -} - -instance ToJSON TableOptions where - toJSON t = object [ - "columns" .= tblOptcolumns t - , "pkey" .= tblOptpkey t ] - + fromInRange = lower <= upper extractQueryResult :: Maybe ResultsWithCount -> ResultsWithCount extractQueryResult = fromMaybe (Nothing, 0, [], "") diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -16,19 +16,17 @@ , containsRole , jwtClaims , tokenJWT + , JWTAttempt(..) ) where -import Lens.Micro -import Lens.Micro.Aeson +import Protolude +import Control.Lens import Data.Aeson (Value (..), parseJSON, toJSON) +import Data.Aeson.Lens import Data.Aeson.Types (parseMaybe, emptyObject, emptyArray) -import qualified Data.ByteString as BS import qualified Data.Vector as V import qualified Data.HashMap.Strict as M -import Data.Maybe (fromMaybe, maybeToList, fromJust) -import Data.Monoid ((<>)) -import Data.String.Conversions (cs) -import Data.Text (Text) +import Data.Maybe (fromJust) import Data.Time.Clock (NominalDiffTime) import PostgREST.QueryBuilder (pgFmtIdent, pgFmtLit, unquoted) import qualified Web.JWT as JWT @@ -39,33 +37,44 @@ have a claim called role, this one is mapped to a SET ROLE statement. -} -claimsToSQL :: M.HashMap Text Value -> [BS.ByteString] +claimsToSQL :: M.HashMap Text Value -> [ByteString] claimsToSQL claims = roleStmts <> varStmts where roleStmts = maybeToList $ - (\r -> "set local role " <> r <> ";") . cs . valueToVariable <$> M.lookup "role" claims + (\r -> "set local role " <> r <> ";") . toS . valueToVariable <$> M.lookup "role" claims varStmts = map setVar $ M.toList (M.delete "role" claims) - setVar (k, val) = "set local " <> cs (pgFmtIdent $ "postgrest.claims." <> k) - <> " = " <> cs (valueToVariable val) <> ";" + setVar (k, val) = "set local " <> toS (pgFmtIdent $ "request.jwt.claim." <> k) + <> " = " <> toS (valueToVariable val) <> ";" valueToVariable = pgFmtLit . unquoted {-| - Receives the JWT secret (from config) and a JWT and - returns a map of JWT claims - In case there is any problem decoding the JWT it returns an error Text + Possible situations encountered with client JWTs -} -jwtClaims :: JWT.Secret -> Text -> NominalDiffTime -> Either Text (M.HashMap Text Value) -jwtClaims _ "" _ = Right M.empty +data JWTAttempt = JWTExpired + | JWTInvalid + | JWTMissingSecret + | JWTClaims (M.HashMap Text Value) + deriving Eq + +{-| + Receives the JWT secret (from config) and a JWT and returns a map + of JWT claims. +-} +jwtClaims :: Maybe JWT.Secret -> Text -> NominalDiffTime -> JWTAttempt +jwtClaims _ "" _ = JWTClaims M.empty jwtClaims secret jwt time = - case isExpired <$> mClaims of - Just True -> Left "JWT expired" - Nothing -> Left "Invalid JWT" - Just False -> Right $ value2map $ fromJust mClaims + case secret of + Nothing -> JWTMissingSecret + Just s -> + let mClaims = toJSON . JWT.claims <$> JWT.decodeAndVerifySignature s jwt in + case isExpired <$> mClaims of + Just True -> JWTExpired + Nothing -> JWTInvalid + Just False -> JWTClaims $ value2map $ fromJust mClaims where isExpired claims = let mExp = claims ^? key "exp" . _Integer in fromMaybe False $ (<= time) . fromInteger <$> mExp - mClaims = toJSON . JWT.claims <$> JWT.decodeAndVerifySignature secret jwt value2map (Object o) = o value2map _ = M.empty @@ -83,6 +92,6 @@ {-| Whether a response from jwtClaims contains a role claim -} -containsRole :: Either Text (M.HashMap Text Value) -> Bool -containsRole (Left _) = False -containsRole (Right claims) = M.member "role" claims +containsRole :: JWTAttempt -> Bool +containsRole (JWTClaims claims) = M.member "role" claims +containsRole _ = False diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -2,12 +2,13 @@ Module : PostgREST.Config Description : Manages PostgREST configuration options. -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. +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. +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. -} @@ -15,49 +16,51 @@ , readOptions , corsPolicy , minimumPgVersion + , PgVersion (..) , AppConfig (..) ) where +import System.IO.Error (IOError) import Control.Applicative +import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BS import qualified Data.CaseInsensitive as CI -import Data.List (intercalate) -import Data.String.Conversions (cs) -import Data.Text (strip) +import qualified Data.Configurator as C +import qualified Data.Configurator.Types as C +import Data.List (lookup) +import Data.Text (strip, intercalate, lines) +import Data.Text.Encoding (encodeUtf8) +import Data.Text.IO (hPutStrLn) import Data.Version (versionBranch) import Network.Wai import Network.Wai.Middleware.Cors (CorsResourcePolicy (..)) -import Options.Applicative +import Options.Applicative hiding (str) import Paths_postgrest (version) -import Prelude -import Safe (readMay) -import Web.JWT (Secret, secret) +import Text.Heredoc +import Text.PrettyPrint.ANSI.Leijen hiding ((<>), (<$>)) --- | Data type to store all command line options +import Protolude hiding (intercalate + , (<>)) + +-- | Config file settings for the server data AppConfig = AppConfig { - configDatabase :: String - , configAnonRole :: String - , configSchema :: String - , configPort :: Int - , configJwtSecret :: Secret - , configPool :: Int - , configMaxRows :: Maybe Integer - , configQuiet :: Bool - } + configDatabase :: Text + , configAnonRole :: Text + , configProxyUri :: Maybe Text + , configSchema :: Text + , configHost :: Text + , configPort :: Int -argParser :: Parser AppConfig -argParser = AppConfig - <$> argument str (help "(REQUIRED) database connection string, e.g. postgres://user:pass@host:port/db" <> metavar "DB_URL") - <*> strOption (long "anonymous" <> short 'a' <> help "(REQUIRED) postgres role to use for non-authenticated requests" <> metavar "ROLE") - <*> strOption (long "schema" <> short 's' <> help "schema to use for API routes" <> metavar "NAME" <> value "public" <> showDefault) - <*> option auto (long "port" <> short 'p' <> help "port number on which to run HTTP server" <> metavar "PORT" <> value 3000 <> showDefault) - <*> (secret . cs <$> - strOption (long "jwt-secret" <> short 'j' <> help "secret used to encrypt and decrypt JWT tokens" <> metavar "SECRET" <> value "secret" <> showDefault)) - <*> option auto (long "pool" <> short 'o' <> help "max connections in database pool" <> metavar "COUNT" <> value 10 <> showDefault) - <*> (readMay <$> strOption (long "max-rows" <> short 'm' <> help "max rows in response" <> metavar "COUNT" <> value "infinity" <> showDefault)) - <*> pure False + , configJwtSecret :: Maybe B.ByteString + , configJwtSecretIsBase64 :: Bool + , configPool :: Int + , configMaxRows :: Maybe Integer + , configReqCheck :: Maybe Text + , configQuiet :: Bool + } + defaultCorsPolicy :: CorsResourcePolicy defaultCorsPolicy = CorsResourcePolicy Nothing ["GET", "POST", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing @@ -78,26 +81,108 @@ where headers = requestHeaders req accHeaders = case lookup "access-control-request-headers" headers of - Just hdrs -> map (CI.mk . cs . strip . cs) $ BS.split ',' hdrs + Just hdrs -> map (CI.mk . toS . strip . toS) $ BS.split ',' hdrs Nothing -> [] -- | User friendly version number -prettyVersion :: String +prettyVersion :: Text prettyVersion = intercalate "." $ map show $ versionBranch version -- | Function to read and parse options from the command line readOptions :: IO AppConfig -readOptions = customExecParser parserPrefs opts - where - opts = info (helper <*> argParser) $ - fullDesc - <> progDesc ( - "PostgREST " - <> prettyVersion - <> " / create a REST API to an existing Postgres database" - ) - parserPrefs = prefs showHelpOnError +readOptions = do + -- First read the config file path from command line + cfgPath <- customExecParser parserPrefs opts + -- Now read the actual config file + conf <- catch + (C.load [C.Required cfgPath]) + configNotfoundHint + handle missingKeyHint $ do + -- db ---------------- + cDbUri <- C.require conf "db-uri" + cDbSchema <- C.require conf "db-schema" + cDbAnon <- C.require conf "db-anon-role" + cPool <- C.lookupDefault 10 conf "db-pool" + -- server ------------ + cHost <- C.lookupDefault "*4" conf "server-host" + cPort <- C.lookupDefault 3000 conf "server-port" + cProxy <- C.lookup conf "server-proxy-uri" + -- jwt --------------- + cJwtSec <- C.lookup conf "jwt-secret" + cJwtB64 <- C.lookupDefault False conf "secret-is-base64" + -- safety ------------ + cMaxRows <- C.lookup conf "max-rows" + cReqCheck <- C.lookup conf "pre-request" + + return $ AppConfig cDbUri cDbAnon cProxy cDbSchema cHost cPort + (encodeUtf8 <$> cJwtSec) cJwtB64 cPool cMaxRows cReqCheck False + + where + opts = info (helper <*> pathParser) $ + fullDesc + <> progDesc ( + "PostgREST " + <> toS prettyVersion + <> " / create a REST API to an existing Postgres database" + ) + <> footerDoc (Just $ + text "Example Config File:" + <> nest 2 (hardline <> exampleCfg) + ) + + parserPrefs = prefs showHelpOnError + + configNotfoundHint :: IOError -> IO a + configNotfoundHint e = do + hPutStrLn stderr $ + "Cannot open config file:\n\t" <> show e + exitFailure + + missingKeyHint :: C.KeyError -> IO a + missingKeyHint (C.KeyError n) = do + hPutStrLn stderr $ + "Required config parameter \"" <> n <> "\" is missing or of wrong type.\n" <> + "Try the --example-config option to see how to configure PostgREST." + exitFailure + + exampleCfg :: Doc + exampleCfg = vsep . map (text . toS) . lines $ + [str|db-uri = "postgres://user:pass@localhost:5432/dbname" + |db-schema = "public" + |db-anon-role = "postgres" + |db-pool = 10 + | + |server-host = "*4" + |server-port = 3000 + | + |## base url for swagger output + |# server-proxy-uri = "" + | + |## choose a secret to enable JWT auth + |## (use "@filename" to load from separate file) + |# jwt-secret = "foo" + |# secret-is-base64 = false + | + |## limit rows in response + |# max-rows = 1000 + | + |## stored proc to exec immediately after auth + |# pre-request = "stored_proc_name" + |] + + +pathParser :: Parser FilePath +pathParser = + strArgument $ + metavar "FILENAME" <> + help "Path to configuration file" + +data PgVersion = PgVersion { + pgvNum :: Int32 +, pgvName :: Text +} + -- | Tells the minimum PostgreSQL version required by this version of PostgREST -minimumPgVersion :: Integer -minimumPgVersion = 90300 +minimumPgVersion :: PgVersion +minimumPgVersion = PgVersion 90300 "9.3" diff --git a/src/PostgREST/DbRequestBuilder.hs b/src/PostgREST/DbRequestBuilder.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/DbRequestBuilder.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE FlexibleContexts #-} +module PostgREST.DbRequestBuilder ( + readRequest +, mutateRequest +) where + +import Control.Applicative +import Control.Lens.Getter (view) +import Control.Lens.Tuple (_1) +import qualified Data.ByteString.Char8 as BS +import Data.List (delete, lookup) +import Data.Maybe (fromJust) +import Data.Text (isInfixOf, dropWhile, drop) +import Data.Tree +import Data.Either.Combinators (mapLeft) + +import Text.Parsec.Error + +import Network.HTTP.Types.Status +import Network.Wai + +import Data.Foldable (foldr1) +import qualified Data.HashMap.Strict as M + +import PostgREST.ApiRequest ( ApiRequest(..) + , Action(..), Target(..) + , PreferRepresentation (..) + ) +import PostgREST.Error (errResponse, formatParserError) +import PostgREST.Parsers +import PostgREST.RangeQuery (NonnegRange, restrictRange) +import PostgREST.QueryBuilder (getJoinConditions, sourceCTEName) +import PostgREST.Types + +import Protolude hiding (from, dropWhile, drop) +import Text.Regex.TDFA ((=~)) +import Unsafe (unsafeHead) + +readRequest :: Maybe Integer -> [Relation] -> [(Text, Text)] -> ApiRequest -> Either Response ReadRequest +readRequest maxRows allRels allProcs apiRequest = + mapLeft (errResponse status400) $ + treeRestrictRange maxRows =<< + augumentRequestWithJoin schema relations =<< + first formatParserError parseReadRequest + where + (schema, rootTableName) = fromJust $ -- Make it safe + let target = iTarget apiRequest in + case target of + (TargetIdent (QualifiedIdentifier s t) ) -> Just (s, t) + (TargetProc (QualifiedIdentifier s p) ) -> Just (s, t) + where + returnType = fromMaybe "" $ lookup p allProcs + -- we are looking for results looking like "SETOF schema.tablename" and want to extract tablename + t = if "SETOF " `isInfixOf` returnType + then drop 1 $ dropWhile (/= '.') returnType + else p + + _ -> Nothing + + action :: Action + action = iAction apiRequest + + parseReadRequest :: Either ParseError ReadRequest + parseReadRequest = addFiltersOrdersRanges apiRequest <*> + pRequestSelect rootName selStr + where + selStr = iSelect apiRequest + rootName = if action == ActionRead + then rootTableName + else sourceCTEName + + relations :: [Relation] + relations = case action of + ActionCreate -> fakeSourceRelations ++ allRels + ActionUpdate -> fakeSourceRelations ++ allRels + ActionDelete -> fakeSourceRelations ++ allRels + ActionInvoke -> fakeSourceRelations ++ allRels + _ -> allRels + where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation + +treeRestrictRange :: Maybe Integer -> ReadRequest -> Either Text ReadRequest +treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` request + where + nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode + nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i) + +augumentRequestWithJoin :: Schema -> [Relation] -> ReadRequest -> Either Text ReadRequest +augumentRequestWithJoin schema allRels request = + (first formatRelationError . addRelations schema allRels Nothing) request + >>= addJoinConditions schema + where + formatRelationError = ("could not find foreign keys between these entities, " <>) + +addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either Text ReadRequest +addRelations schema allRelations parentNode (Node readNode@(query, (name, _, alias)) forest) = + case parentNode of + (Just (Node (Select{from=[parentNodeTable]}, (_, _, _)) _)) -> + Node <$> readNode' <*> forest' + where + forest' = updateForest $ hush node' + node' = Node <$> readNode' <*> pure forest + readNode' = addRel readNode <$> rel + rel :: Either Text Relation + rel = note ("no relation between " <> parentNodeTable <> " and " <> name) + $ findRelation schema name parentNodeTable + + where + findRelation s nodeTableName parentNodeTableName = + find (\r -> + s == tableSchema (relTable r) && -- match schema for relation table + s == tableSchema (relFTable r) && -- match schema for relation foriegn table + ( + + -- (request) => projects { ..., clients{...} } + -- will match + -- (relation type) => parent + -- (entity) => clients {id} + -- (foriegn entity) => projects {client_id} + ( + nodeTableName == tableName (relTable r) && -- match relation table name + parentNodeTableName == tableName (relFTable r) -- match relation foreign table name + ) || + + + -- (request) => projects { ..., client_id{...} } + -- will match + -- (relation type) => parent + -- (entity) => clients {id} + -- (foriegn entity) => projects {client_id} + ( + parentNodeTableName == tableName (relFTable r) && + length (relFColumns r) == 1 && + nodeTableName `colMatches` (colName . unsafeHead . relFColumns) r + ) + + -- (request) => project_id { ..., client_id{...} } + -- will match + -- (relation type) => parent + -- (entity) => clients {id} + -- (foriegn entity) => projects {client_id} + -- this case works becasue before reaching this place + -- addRelation will turn project_id to project so the above condition will match + ) + ) allRelations + where n `colMatches` rc = (toS ("^" <> rc <> "_?(?:|[iI][dD]|[fF][kK])$") :: BS.ByteString) =~ (toS n :: BS.ByteString) + addRel :: (ReadQuery, (NodeName, Maybe Relation, Maybe Alias)) -> Relation -> (ReadQuery, (NodeName, Maybe Relation, Maybe Alias)) + addRel (query', (n, _, a)) r = (query' {from=fromRelation}, (n, Just r, a)) + where fromRelation = map (\t -> if t == n then tableName (relTable r) else t) (from query') + + _ -> n' <$> updateForest (Just (n' forest)) + where + n' = Node (query, (name, Just r, alias)) + t = Table schema name True -- !!! TODO find another way to get the table from the query + r = Relation t [] t [] Root Nothing Nothing Nothing + where + updateForest :: Maybe ReadRequest -> Either Text [ReadRequest] + updateForest n = mapM (addRelations schema allRelations n) forest + +addJoinConditions :: Schema -> ReadRequest -> Either Text ReadRequest +addJoinConditions schema (Node nn@(query, (n, r, a)) forest) = + case r of + Just Relation{relType=Root} -> Node nn <$> updatedForest -- this is the root node + Just rel@Relation{relType=Child} -> Node (addCond query (getJoinConditions rel),(n,r,a)) <$> updatedForest + Just Relation{relType=Parent} -> Node nn <$> updatedForest + Just rel@Relation{relType=Many, relLTable=(Just linkTable)} -> + Node (qq, (n, r, a)) <$> updatedForest + where + query' = addCond query (getJoinConditions rel) + qq = query'{from=tableName linkTable : from query'} + _ -> Left "unknown relation" + where + updatedForest = mapM (addJoinConditions schema) forest + addCond query' con = query'{flt_=con ++ flt_ query'} + +addFiltersOrdersRanges :: ApiRequest -> Either ParseError (ReadRequest -> ReadRequest) +addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [ + flip (foldr addFilter) <$> filters, + flip (foldr addOrder) <$> orders, + flip (foldr addRange) <$> ranges + ] + {- + The esence of what is going on above is that we are composing tree functions + of type (ReadRequest->ReadRequest) that are in (Either ParseError a) context + -} + where + filters :: Either ParseError [(Path, Filter)] + filters = mapM pRequestFilter flts + where + action = iAction apiRequest + flts + | action == ActionRead = iFilters apiRequest + | action == ActionInvoke = iFilters apiRequest + | otherwise = filter (( "." `isInfixOf` ) . fst) $ iFilters apiRequest -- there can be no filters on the root table whre we are doing insert/update + orders :: Either ParseError [(Path, [OrderTerm])] + orders = mapM pRequestOrder $ iOrder apiRequest + ranges :: Either ParseError [(Path, NonnegRange)] + ranges = mapM pRequestRange $ M.toList $ iRange apiRequest + +addFilterToNode :: Filter -> ReadRequest -> ReadRequest +addFilterToNode flt (Node (q@Select {flt_=flts}, i) f) = Node (q {flt_=flt:flts}, i) f + +addFilter :: (Path, Filter) -> ReadRequest -> ReadRequest +addFilter = addProperty addFilterToNode + +addOrderToNode :: [OrderTerm] -> ReadRequest -> ReadRequest +addOrderToNode o (Node (q,i) f) = Node (q{order=Just o}, i) f + +addOrder :: (Path, [OrderTerm]) -> ReadRequest -> ReadRequest +addOrder = addProperty addOrderToNode + +addRangeToNode :: NonnegRange -> ReadRequest -> ReadRequest +addRangeToNode r (Node (q,i) f) = Node (q{range_=r}, i) f + +addRange :: (Path, NonnegRange) -> ReadRequest -> ReadRequest +addRange = addProperty addRangeToNode + +addProperty :: (a -> ReadRequest -> ReadRequest) -> (Path, a) -> ReadRequest -> ReadRequest +addProperty f ([], a) n = f a n +addProperty f (path, a) (Node rn forest) = + case targetNode of + Nothing -> Node rn forest -- the property is silenty dropped in the Request does not contain the required path + Just tn -> Node rn (addProperty f (remainingPath, a) tn:restForest) + where + targetNodeName:remainingPath = path + (targetNode,restForest) = splitForest targetNodeName forest + splitForest :: NodeName -> Forest ReadNode -> (Maybe ReadRequest, Forest ReadNode) + splitForest name forst = + case maybeNode of + Nothing -> (Nothing,forest) + Just node -> (Just node, delete node forest) + where + maybeNode :: Maybe ReadRequest + maybeNode = find fnd forst + where + fnd :: ReadRequest -> Bool + fnd (Node (_,(n,_,_)) _) = n == name + +-- in a relation where one of the tables mathces "TableName" +-- replace the name to that table with pg_source +-- this "fake" relations is needed so that in a mutate query +-- we can look a the "returning *" part which is wrapped with a "with" +-- as just another table that has relations with other tables +toSourceRelation :: TableName -> Relation -> Maybe Relation +toSourceRelation mt r@(Relation t _ ft _ _ rt _ _) + | mt == tableName t = Just $ r {relTable=t {tableName=sourceCTEName}} + | mt == tableName ft = Just $ r {relFTable=t {tableName=sourceCTEName}} + | Just mt == (tableName <$> rt) = Just $ r {relLTable=(\tbl -> tbl {tableName=sourceCTEName}) <$> rt} + | otherwise = Nothing + +mutateRequest :: ApiRequest -> ReadRequest -> Either Response MutateRequest +mutateRequest apiRequest readReq = mapLeft (errResponse status400) $ + case action of + ActionCreate -> Right $ Insert rootTableName payload returnings + ActionUpdate -> Update rootTableName <$> pure payload <*> filters <*> pure returnings + ActionDelete -> Delete rootTableName <$> filters <*> pure returnings + _ -> Left "Unsupported HTTP verb" + where + action = iAction apiRequest + payload = fromJust $ iPayload apiRequest + rootTableName = -- TODO: Make it safe + let target = iTarget apiRequest in + case target of + (TargetIdent (QualifiedIdentifier _ t) ) -> t + _ -> undefined + fieldNames :: ReadRequest -> PreferRepresentation -> [FieldName] + fieldNames _ None = [] + fieldNames (Node (sel, _) forest) _ = + map (fst . view _1) (select sel) ++ map colName fks + where + fks = concatMap (fromMaybe [] . f) forest + f (Node (_, (_, Just Relation{relFColumns=cols, relType=Parent}, _)) _) = Just cols + f _ = Nothing + returnings = fieldNames readReq (iPreferRepresentation apiRequest) + filters = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters + where mutateFilters = filter (not . ( "." `isInfixOf` ) . fst) $ iFilters apiRequest -- update/delete filters can be only on the root table diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs --- a/src/PostgREST/DbStructure.hs +++ b/src/PostgREST/DbStructure.hs @@ -6,8 +6,6 @@ module PostgREST.DbStructure ( getDbStructure , accessibleTables -, doesProcExist -, doesProcReturnJWT ) where import qualified Hasql.Decoders as HD @@ -15,21 +13,18 @@ import qualified Hasql.Query as H import Control.Applicative -import Control.Monad (join, replicateM) -import Data.Functor.Contravariant (contramap) -import Data.List (elemIndex, find, sort, - subsequences, transpose) -import Data.Maybe (fromJust, fromMaybe, isJust, - listToMaybe, mapMaybe) -import Data.Monoid -import Data.Text (Text, split) +import Data.List (elemIndex) +import Data.Maybe (fromJust) +import Data.Text (split, strip, + breakOn, dropAround) +import qualified Data.Text as T import qualified Hasql.Session as H import PostgREST.Types import Text.InterpolatedString.Perl6 (q) -import Data.Int (Int32) import GHC.Exts (groupWith) -import Prelude +import Protolude +import Unsafe (unsafeHead) getDbStructure :: Schema -> H.Session DbStructure getDbStructure schema = do @@ -38,6 +33,7 @@ syns <- H.query () $ allSynonyms cols rels <- H.query () $ allRelations tabs cols keys <- H.query () $ allPrimaryKeys tabs + procs <- H.query schema accessibleProcs let rels' = (addManyToManyRelations . raiseRelations schema syns . addParentRelations . addSynonymousRelations syns) rels cols' = addForeignKeys rels' cols @@ -48,13 +44,9 @@ , dbColumns = cols' , dbRelations = rels' , dbPrimaryKeys = keys' + , dbProcs = procs } -encodeQi :: HE.Params QualifiedIdentifier -encodeQi = - contramap qiSchema (HE.value HE.text) <> - contramap qiName (HE.value HE.text) - decodeTables :: HD.Result [Table] decodeTables = HD.rowsList tblRow @@ -104,33 +96,37 @@ <*> HD.value HD.text <*> HD.value HD.text <*> HD.value HD.text <*> HD.value HD.text -doesProcExist :: H.Query QualifiedIdentifier Bool -doesProcExist = - H.statement sql encodeQi (HD.singleRow (HD.value HD.bool)) True +accessibleProcs :: H.Query Schema [(Text, ProcDescription)] +accessibleProcs = + H.statement sql (HE.value HE.text) + (map addName <$> HD.rowsList (ProcDescription <$> HD.value HD.text + <*> (parseArgs <$> HD.value HD.text) + <*> HD.value HD.text)) True where - sql = [q| SELECT EXISTS ( - SELECT 1 - FROM pg_catalog.pg_namespace n - JOIN pg_catalog.pg_proc p - ON pronamespace = n.oid - WHERE nspname = $1 - AND proname = $2 - ) |] + addName :: ProcDescription -> (Text, ProcDescription) + addName pd = (pdName pd, pd) -doesProcReturnJWT :: H.Query QualifiedIdentifier Bool -doesProcReturnJWT = - H.statement sql encodeQi (HD.singleRow (HD.value HD.bool)) True - where - sql = [q| SELECT EXISTS ( - SELECT 1 - FROM pg_catalog.pg_namespace n - JOIN pg_catalog.pg_proc p - ON pronamespace = n.oid - WHERE nspname = $1 - AND proname = $2 - AND pg_catalog.pg_get_function_result(p.oid) like '%jwt_claims' - ) |] + parseArgs :: Text -> [PgArg] + parseArgs = mapMaybe (parseArg . strip) . split (==',') + parseArg :: Text -> Maybe PgArg + parseArg a = + let (body, def) = breakOn " DEFAULT " a + (name, typ) = breakOn " " body in + if T.null typ + then Nothing + else Just $ + PgArg (dropAround (== '"') name) (strip typ) (T.null def) + + sql = [q| + SELECT p.proname as "proc_name", + pg_get_function_arguments(p.oid) as "args", + pg_get_function_result(p.oid) as "return_type" + FROM pg_namespace n + JOIN pg_proc p + ON pronamespace = n.oid + WHERE n.nspname = $1|] + accessibleTables :: H.Query Schema [Table] accessibleTables = H.statement sql (HE.value HE.text) decodeTables True @@ -161,7 +157,9 @@ synonymousColumns :: [(Column,Column)] -> [Column] -> [[Column]] synonymousColumns allSyns cols = synCols' where - syns = sort $ filter ((== colTable (head cols)) . colTable . fst) allSyns + syns = case headMay cols of + Just firstCol -> sort $ filter ((== colTable firstCol) . colTable . fst) allSyns + Nothing -> [] synCols  = transpose $ map (\c -> map snd $ filter ((== c) . fst) syns) cols synCols' = (filter sameTable . filter matchLength) synCols matchLength cs = length cols == length cs @@ -175,11 +173,10 @@ fk col = join $ relToFk col <$> find (lookupFn col) rels lookupFn :: Column -> Relation -> Bool lookupFn c Relation{relColumns=cs, relType=rty} = c `elem` cs && rty==Child - -- lookupFn _ _ = False - relToFk col Relation{relColumns=cols, relFColumns=colsF} = ForeignKey <$> colF - where - pos = elemIndex col cols - colF = (colsF !!) <$> pos + relToFk col Relation{relColumns=cols, relFColumns=colsF} = do + pos <- elemIndex col cols + colF <- atMay colsF pos + return $ ForeignKey colF addSynonymousRelations :: [(Column,Column)] -> [Relation] -> [Relation] addSynonymousRelations _ [] = [] @@ -187,7 +184,7 @@ where synRelsP = synRels (relColumns rel) (\t cs -> rel{relTable=t,relColumns=cs}) synRelsF = synRels (relFColumns rel) (\t cs -> rel{relFTable=t,relFColumns=cs}) - synRels cols mapFn = map (\cs -> mapFn (colTable $ head cs) cs) $ synonymousColumns syns cols + synRels cols mapFn = map (\cs -> mapFn (colTable $ unsafeHead cs) cs) $ synonymousColumns syns cols addParentRelations :: [Relation] -> [Relation] addParentRelations [] = [] @@ -220,8 +217,8 @@ where cols = relFColumns rel table = relFTable rel - newCols = listToMaybe $ filter ((== schema) . tableSchema . colTable . head) (synonymousColumns syns cols) - newTable = (colTable . head) <$> newCols + newCols = listToMaybe $ filter ((== schema) . tableSchema . colTable . unsafeHead) (synonymousColumns syns cols) + newTable = (colTable . unsafeHead) <$> newCols synonymousPrimaryKeys :: [(Column,Column)] -> [PrimaryKey] -> [PrimaryKey] synonymousPrimaryKeys _ [] = [] @@ -289,13 +286,13 @@ CASE WHEN bt.typelem <> 0::oid AND bt.typlen = (-1) THEN 'ARRAY'::text WHEN nbt.nspname = 'pg_catalog'::name THEN format_type(t.typbasetype, NULL::integer) - ELSE 'USER-DEFINED'::text + ELSE format_type(a.atttypid, a.atttypmod) END ELSE CASE WHEN t.typelem <> 0::oid AND t.typlen = (-1) THEN 'ARRAY'::text WHEN nt.nspname = 'pg_catalog'::name THEN format_type(a.atttypid, NULL::integer) - ELSE 'USER-DEFINED'::text + ELSE format_type(a.atttypid, a.atttypmod) END END::information_schema.character_data AS data_type, information_schema._pg_char_max_length(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS character_maximum_length, @@ -560,73 +557,73 @@ where -- query explanation at https://gist.github.com/ruslantalpa/2eab8c930a65e8043d8f sql = [q| - WITH view_columns AS ( - SELECT - c.oid AS view_oid, - a.attname::information_schema.sql_identifier AS column_name - FROM pg_attribute a - JOIN pg_class c ON a.attrelid = c.oid - JOIN pg_namespace nc ON c.relnamespace = nc.oid - WHERE - NOT pg_is_other_temp_schema(nc.oid) - AND a.attnum > 0 - AND NOT a.attisdropped - AND (c.relkind = 'v'::"char") - AND nc.nspname NOT IN ('information_schema', 'pg_catalog') + with view_columns as ( + select + c.oid as view_oid, + a.attname::information_schema.sql_identifier as column_name + from pg_attribute a + join pg_class c on a.attrelid = c.oid + join pg_namespace nc on c.relnamespace = nc.oid + where + not pg_is_other_temp_schema(nc.oid) + and a.attnum > 0 + and not a.attisdropped + and (c.relkind = 'v'::"char") + and nc.nspname not in ('information_schema', 'pg_catalog') ), - view_column_usage AS ( - SELECT DISTINCT - v.oid as view_oid, - nv.nspname::information_schema.sql_identifier AS view_schema, - v.relname::information_schema.sql_identifier AS view_name, - nt.nspname::information_schema.sql_identifier AS table_schema, - t.relname::information_schema.sql_identifier AS table_name, - a.attname::information_schema.sql_identifier AS column_name, - pg_get_viewdef(v.oid)::information_schema.character_data AS view_definition - FROM pg_namespace nv - JOIN pg_class v ON nv.oid = v.relnamespace - JOIN pg_depend dv ON v.oid = dv.refobjid - JOIN pg_depend dt ON dv.objid = dt.objid - JOIN pg_class t ON dt.refobjid = t.oid - JOIN pg_namespace nt ON t.relnamespace = nt.oid - JOIN pg_attribute a ON t.oid = a.attrelid AND dt.refobjsubid = a.attnum + view_column_usage as ( + select distinct + v.oid as view_oid, + nv.nspname::information_schema.sql_identifier as view_schema, + v.relname::information_schema.sql_identifier as view_name, + nt.nspname::information_schema.sql_identifier as table_schema, + t.relname::information_schema.sql_identifier as table_name, + a.attname::information_schema.sql_identifier as column_name, + pg_get_viewdef(v.oid)::information_schema.character_data as view_definition + from pg_namespace nv + join pg_class v on nv.oid = v.relnamespace + join pg_depend dv on v.oid = dv.refobjid + join pg_depend dt on dv.objid = dt.objid + join pg_class t on dt.refobjid = t.oid + join pg_namespace nt on t.relnamespace = nt.oid + join pg_attribute a on t.oid = a.attrelid and dt.refobjsubid = a.attnum - WHERE - nv.nspname not in ('information_schema', 'pg_catalog') - AND v.relkind = 'v'::"char" - AND dv.refclassid = 'pg_class'::regclass::oid - AND dv.classid = 'pg_rewrite'::regclass::oid - AND dv.deptype = 'i'::"char" - AND dv.refobjid <> dt.refobjid - AND dt.classid = 'pg_rewrite'::regclass::oid - AND dt.refclassid = 'pg_class'::regclass::oid - AND (t.relkind = ANY (ARRAY['r'::"char", 'v'::"char", 'f'::"char"])) + where + nv.nspname not in ('information_schema', 'pg_catalog') + and v.relkind = 'v'::"char" + and dv.refclassid = 'pg_class'::regclass::oid + and dv.classid = 'pg_rewrite'::regclass::oid + and dv.deptype = 'i'::"char" + and dv.refobjid <> dt.refobjid + and dt.classid = 'pg_rewrite'::regclass::oid + and dt.refclassid = 'pg_class'::regclass::oid + and (t.relkind = any (array['r'::"char", 'v'::"char", 'f'::"char"])) ), - candidates AS ( - SELECT - vcu.*, - ( - SELECT CASE WHEN match IS NOT NULL THEN coalesce(match[7], match[4]) END - FROM REGEXP_MATCHES( - CONCAT('SELECT ', SPLIT_PART(vcu.view_definition, 'SELECT', 2)), - CONCAT('SELECT.*?((',vcu.table_name,')|(\w+))\.(', vcu.column_name, ')(\sAS\s(")?([^"]+)\6)?.*?FROM.*?',vcu.table_schema,'\.(\2|',vcu.table_name,'\s+(AS\s)?\3)'), - 'ns' - ) match - ) AS view_column_name - FROM view_column_usage AS vcu + candidates as ( + select + vcu.*, + ( + select case when match is not null then coalesce(match[8], match[7], match[4]) end + from regexp_matches( + CONCAT('SELECT ', SPLIT_PART(vcu.view_definition, 'SELECT', 2)), + CONCAT('SELECT.*?((',vcu.table_name,')|(\w+))\.(', vcu.column_name, ')(\s+AS\s+("([^"]+)"|([^, \n\t]+)))?.*?FROM.*?',vcu.table_schema,'\.(\2|',vcu.table_name,'\s+(as\s)?\3)'), + 'nsi' + ) match + ) as view_column_name + from view_column_usage as vcu ) - SELECT - c.table_schema, - c.table_name, - c.column_name AS table_column_name, - c.view_schema, - c.view_name, - c.view_column_name - FROM view_columns AS vc, candidates AS c - WHERE - vc.view_oid = c.view_oid AND - vc.column_name = c.view_column_name - ORDER BY c.view_schema, c.view_name, c.table_name, c.view_column_name + select + c.table_schema, + c.table_name, + c.column_name as table_column_name, + c.view_schema, + c.view_name, + c.view_column_name + from view_columns as vc, candidates as c + where + vc.view_oid = c.view_oid + and vc.column_name = c.view_column_name + order by c.view_schema, c.view_name, c.table_name, c.view_column_name |] synonymFromRow :: [Column] -> (Text,Text,Text,Text,Text,Text) -> Maybe (Column,Column) diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -2,74 +2,108 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} -module PostgREST.Error (pgErrResponse, errResponse) where - +module PostgREST.Error (apiRequestErrResponse, pgErrResponse, errResponse, prettyUsageError, singularityError, formatGeneralError, formatParserError) where +import Protolude import Data.Aeson ((.=)) import qualified Data.Aeson as JSON -import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) -import Data.String.Conversions (cs) -import Data.Text (Text) -import qualified Data.Text as T +import Data.Text (replace, strip, unwords) import qualified Hasql.Pool as P import qualified Hasql.Session as H -import Network.HTTP.Types.Header import qualified Network.HTTP.Types.Status as HT import Network.Wai (Response, responseLBS) +import PostgREST.ApiRequest (toHeader, toMime, ContentType(..), ApiRequestError(..)) +import Text.Parsec.Error +apiRequestErrResponse :: ApiRequestError -> Response +apiRequestErrResponse err = + case err of + ErrorActionInappropriate -> errResponse HT.status405 "Bad Request" + ErrorInvalidBody errorMessage -> errResponse HT.status400 $ toS errorMessage + ErrorInvalidRange -> errResponse HT.status416 "HTTP Range error" + errResponse :: HT.Status -> Text -> Response -errResponse status message = responseLBS status [(hContentType, "application/json")] (cs $ T.concat ["{\"message\":\"",message,"\"}"]) +errResponse status message = jsonErrResponse status $ JSON.object ["message" .= message] +jsonErrResponse :: HT.Status -> JSON.Value -> Response +jsonErrResponse status message = responseLBS status [toHeader CTApplicationJSON] $ JSON.encode message + pgErrResponse :: Bool -> P.UsageError -> Response pgErrResponse authed e = let status = httpStatus authed e - jsonType = (hContentType, "application/json") + jsonType = toHeader CTApplicationJSON wwwAuth = ("WWW-Authenticate", "Bearer") hdrs = if status == HT.status401 then [jsonType, wwwAuth] else [jsonType] in responseLBS status hdrs (JSON.encode e) +prettyUsageError :: P.UsageError -> Text +prettyUsageError (P.ConnectionError e) = + "Database connection error:\n" <> toS (fromMaybe "" e) +prettyUsageError e = show $ JSON.encode e + +singularityError :: Integer -> Response +singularityError numRows = + responseLBS HT.status406 + [toHeader CTSingularJSON] + $ toS . formatGeneralError + "JSON object requested, multiple (or no) rows returned" + $ unwords + [ "Results contain", show numRows, "rows," + , toS (toMime CTSingularJSON), "requires 1 row" + ] + +formatParserError :: ParseError -> Text +formatParserError e = formatGeneralError message details + where + message = show $ errorPos e + details = strip $ replace "\n" " " $ toS + $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e) + +formatGeneralError :: Text -> Text -> Text +formatGeneralError message details = toS . JSON.encode $ + JSON.object ["message" .= message, "details" .= details] + instance JSON.ToJSON P.UsageError where toJSON (P.ConnectionError e) = JSON.object [ - "code" .= ("" :: T.Text), - "message" .= ("Connection error" :: T.Text), - "details" .= (cs (fromMaybe "" e) :: T.Text)] + "code" .= ("" :: Text), + "message" .= ("Connection error" :: Text), + "details" .= (toS $ fromMaybe "" e :: Text)] toJSON (P.SessionError e) = JSON.toJSON e -- H.Error instance JSON.ToJSON H.Error where toJSON (H.ResultError (H.ServerError c m d h)) = JSON.object [ - "code" .= (cs c::T.Text), - "message" .= (cs m::T.Text), - "details" .= (fmap cs d::Maybe T.Text), - "hint" .= (fmap cs h::Maybe T.Text)] + "code" .= (toS c::Text), + "message" .= (toS m::Text), + "details" .= (fmap toS d::Maybe Text), + "hint" .= (fmap toS h::Maybe Text)] toJSON (H.ResultError (H.UnexpectedResult m)) = JSON.object [ - "message" .= (cs m::T.Text)] + "message" .= (m::Text)] toJSON (H.ResultError (H.RowError i H.EndOfInput)) = JSON.object [ - "message" .= ("Row error: end of input"::String), + "message" .= ("Row error: end of input"::Text), "details" .= - ("Attempt to parse more columns than there are in the result"::String), - "details" .= ("Row number " <> show i)] + ("Attempt to parse more columns than there are in the result"::Text), + "details" .= (("Row number " <> show i)::Text)] toJSON (H.ResultError (H.RowError i H.UnexpectedNull)) = JSON.object [ - "message" .= ("Row error: unexpected null"::String), - "details" .= ("Attempt to parse a NULL as some value."::String), - "details" .= ("Row number " <> show i)] + "message" .= ("Row error: unexpected null"::Text), + "details" .= ("Attempt to parse a NULL as some value."::Text), + "details" .= (("Row number " <> show i)::Text)] toJSON (H.ResultError (H.RowError i (H.ValueError d))) = JSON.object [ - "message" .= ("Row error: Wrong value parser used"::String), + "message" .= ("Row error: Wrong value parser used"::Text), "details" .= d, - "details" .= ("Row number " <> show i)] + "details" .= (("Row number " <> show i)::Text)] toJSON (H.ResultError (H.UnexpectedAmountOfRows i)) = JSON.object [ - "message" .= ("Unexpected amount of rows"::String), + "message" .= ("Unexpected amount of rows"::Text), "details" .= i] toJSON (H.ClientError d) = JSON.object [ - "message" .= ("Database client error"::String), - "details" .= (fmap cs d::Maybe T.Text)] + "message" .= ("Database client error"::Text), + "details" .= (fmap toS d::Maybe Text)] httpStatus :: Bool -> P.UsageError -> HT.Status httpStatus _ (P.ConnectionError _) = HT.status500 httpStatus authed (P.SessionError (H.ResultError (H.ServerError c _ _ _))) = - case cs c of + case toS c of '0':'8':_ -> HT.status503 -- pg connection err '0':'9':_ -> HT.status500 -- triggered action exception '0':'L':_ -> HT.status403 -- invalid grantor @@ -90,8 +124,10 @@ '5':'8':_ -> HT.status500 -- system error 'F':'0':_ -> HT.status500 -- conf file error 'H':'V':_ -> HT.status500 -- foreign data wrapper error + "P0001" -> HT.status400 -- default code for "raise" 'P':'0':_ -> HT.status500 -- PL/pgSQL Error 'X':'X':_ -> HT.status500 -- internal Error + "42883" -> HT.status404 -- undefined function "42P01" -> HT.status404 -- undefined table "42501" -> if authed then HT.status403 else HT.status401 -- insufficient privilege _ -> HT.status400 diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -5,49 +5,51 @@ import Data.Aeson (Value (..)) import qualified Data.HashMap.Strict as M -import Data.String.Conversions (cs) -import Data.Text import qualified Hasql.Transaction as H -import Network.HTTP.Types.Header (hAccept) -import Network.HTTP.Types.Status (status400, status415) -import Network.Wai (Application, Request (..), - Response, requestHeaders) +import Network.HTTP.Types.Status (unauthorized401, status500) +import Network.Wai (Application, Response, + responseLBS) import Network.Wai.Middleware.Cors (cors) import Network.Wai.Middleware.Gzip (def, gzip) import Network.Wai.Middleware.Static (only, staticPolicy) -import PostgREST.ApiRequest (ApiRequest(..), pickContentType) -import PostgREST.Auth (claimsToSQL) +import PostgREST.ApiRequest (ApiRequest(..), ContentType(..), + toHeader) +import PostgREST.Auth (claimsToSQL, JWTAttempt(..)) import PostgREST.Config (AppConfig (..), corsPolicy) import PostgREST.Error (errResponse) -import Prelude hiding (concat, null) +import Protolude hiding (concat, null) -runWithClaims :: AppConfig -> Either Text (M.HashMap Text Value) -> +runWithClaims :: AppConfig -> JWTAttempt -> (ApiRequest -> H.Transaction Response) -> ApiRequest -> H.Transaction Response runWithClaims conf eClaims app req = case eClaims of - Left e -> clientErr e - Right claims -> do - -- role claim defaults to anon if not specified in jwt - H.sql . mconcat . claimsToSQL $ M.union claims (M.singleton "role" anon) - app req + JWTExpired -> return $ unauthed "JWT expired" + JWTInvalid -> return $ unauthed "JWT invalid" + JWTMissingSecret -> return $ errResponse status500 "Server lacks JWT secret" + JWTClaims claims -> do + -- role claim defaults to anon if not specified in jwt + let setClaims = claimsToSQL (M.union claims (M.singleton "role" anon)) + H.sql $ mconcat setClaims + mapM_ H.sql customReqCheck + app req where - anon = String . cs $ configAnonRole conf - clientErr = return . errResponse status400 - -unsupportedAccept :: Application -> Application -unsupportedAccept app req respond = - case accept of - Left _ -> respond $ errResponse status415 "Unsupported Accept header, try: application/json" - Right _ -> app req respond - where accept = pickContentType $ lookup hAccept $ requestHeaders req + anon = String . toS $ configAnonRole conf + customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf + unauthed message = responseLBS unauthorized401 + [ toHeader CTApplicationJSON + , ( "WWW-Authenticate" + , "Bearer error=\"invalid_token\", " <> + "error_description=\"" <> message <> "\"" + ) + ] + (toS $ "{\"message\":\""<>message<>"\"}") defaultMiddle :: Application -> Application defaultMiddle = gzip def . cors corsPolicy . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) - . unsupportedAccept diff --git a/src/PostgREST/OpenAPI.hs b/src/PostgREST/OpenAPI.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/OpenAPI.hs @@ -0,0 +1,357 @@ +{-# LANGUAGE OverloadedStrings #-} + +module PostgREST.OpenAPI ( + encodeOpenAPI + , isMalformedProxyUri + , pickProxy + ) where + +import Control.Lens +import Data.Aeson (decode, encode) +import Data.HashMap.Strict.InsOrd (InsOrdHashMap, fromList) +import Data.Maybe (fromJust) +import Data.String (IsString (..)) +import Data.Text (unpack, pack, concat, intercalate, init, tail, toLower) +import qualified Data.Set as Set +import Network.URI (parseURI, isAbsoluteURI, + URI (..), URIAuth (..)) + +import Protolude hiding (concat, (&), Proxy, get, intercalate) + +import Data.Swagger + +import PostgREST.ApiRequest (ContentType(..), toMime) +import PostgREST.Config (prettyVersion) +import PostgREST.QueryBuilder (operators) +import PostgREST.Types (Table(..), Column(..), PgArg(..), + Proxy(..), ProcDescription(..)) + +makeMimeList :: [ContentType] -> MimeList +makeMimeList cs = MimeList $ map (fromString . toS . toMime) cs + +toSwaggerType :: Text -> SwaggerType t +toSwaggerType "text" = SwaggerString +toSwaggerType "integer" = SwaggerInteger +toSwaggerType "boolean" = SwaggerBoolean +toSwaggerType "numeric" = SwaggerNumber +toSwaggerType _ = SwaggerString + +makeTableDef :: (Table, [Column], [Text]) -> (Text, Schema) +makeTableDef (t, cs, _) = + let tn = tableName t in + (tn, (mempty :: Schema) + & type_ .~ SwaggerObject + & properties .~ fromList (map makeProperty cs)) + +makeProperty :: Column -> (Text, Referenced Schema) +makeProperty c = (colName c, Inline u) + where + r = mempty :: Schema + s = if null $ colEnum c + then r + else r & enum_ .~ decode (encode (colEnum c)) + t = s & type_ .~ toSwaggerType (colType c) + u = t & format ?~ colType c + +makeProcDef :: ProcDescription -> (Text, Schema) +makeProcDef pd = ("(rpc) " <> pdName pd, s) + where + s = (mempty :: Schema) + & type_ .~ SwaggerObject + & properties .~ fromList (map makeProcProperty (pdArgs pd)) + & required .~ map pgaName (filter pgaReq (pdArgs pd)) + +makeProcProperty :: PgArg -> (Text, Referenced Schema) +makeProcProperty (PgArg n t _) = (n, Inline s) + where + s = (mempty :: Schema) + & type_ .~ toSwaggerType t + & format ?~ t + +makeOperatorPattern :: Text +makeOperatorPattern = + intercalate "|" + [ concat ["^", x, y, "[.]"] | + x <- ["not[.]", ""], + y <- map fst operators ] + +makeRowFilter :: Column -> Param +makeRowFilter c = + (mempty :: Param) + & name .~ colName c + & required ?~ False + & schema .~ ParamOther ((mempty :: ParamOtherSchema) + & in_ .~ ParamQuery + & type_ .~ SwaggerString + & format ?~ colType c + & pattern ?~ makeOperatorPattern) + +makeRowFilters :: [Column] -> [Param] +makeRowFilters = map makeRowFilter + +makeOrderItems :: [Column] -> [Text] +makeOrderItems cs = + [ concat [x, y, z] | + x <- map colName cs, + y <- [".asc", ".desc", ""], + z <- [".nullsfirst", ".nulllast", ""] + ] + +makeRangeParams :: [Param] +makeRangeParams = + [ (mempty :: Param) + & name .~ "Range" + & description ?~ "Limiting and Pagination" + & required ?~ False + & schema .~ ParamOther ((mempty :: ParamOtherSchema) + & in_ .~ ParamHeader + & type_ .~ SwaggerString) + , (mempty :: Param) + & name .~ "Range-Unit" + & description ?~ "Limiting and Pagination" + & required ?~ False + & schema .~ ParamOther ((mempty :: ParamOtherSchema) + & in_ .~ ParamHeader + & type_ .~ SwaggerString + & default_ .~ decode "\"items\"") + , (mempty :: Param) + & name .~ "offset" + & description ?~ "Limiting and Pagination" + & required ?~ False + & schema .~ ParamOther ((mempty :: ParamOtherSchema) + & in_ .~ ParamQuery + & type_ .~ SwaggerString) + , (mempty :: Param) + & name .~ "limit" + & description ?~ "Limiting and Pagination" + & required ?~ False + & schema .~ ParamOther ((mempty :: ParamOtherSchema) + & in_ .~ ParamQuery + & type_ .~ SwaggerString) + ] + +makePreferParam :: [Text] -> Param +makePreferParam ts = + (mempty :: Param) + & name .~ "Prefer" + & description ?~ "Preference" + & required ?~ False + & schema .~ ParamOther ((mempty :: ParamOtherSchema) + & in_ .~ ParamHeader + & type_ .~ SwaggerString + & enum_ .~ decode (encode ts)) + +makeSelectParam :: Param +makeSelectParam = + (mempty :: Param) + & name .~ "select" + & description ?~ "Filtering Columns" + & required ?~ False + & schema .~ ParamOther ((mempty :: ParamOtherSchema) + & in_ .~ ParamQuery + & type_ .~ SwaggerString) + +makeGetParams :: [Column] -> [Param] +makeGetParams [] = + makeRangeParams ++ + [ makeSelectParam + , makePreferParam ["count=none"] + ] +makeGetParams cs = + makeRangeParams ++ + [ makeSelectParam + , (mempty :: Param) + & name .~ "order" + & description ?~ "Ordering" + & required ?~ False + & schema .~ ParamOther ((mempty :: ParamOtherSchema) + & in_ .~ ParamQuery + & type_ .~ SwaggerString + & enum_ .~ decode (encode $ makeOrderItems cs)) + , makePreferParam ["count=none"] + ] + +makePostParams :: Text -> [Param] +makePostParams tn = + [ makePreferParam ["return=representation", + "return=minimal", "return=none"] + , (mempty :: Param) + & name .~ "body" + & description ?~ tn + & required ?~ False + & schema .~ ParamBody (Ref (Reference tn)) + ] + +makeProcParam :: Text -> [Param] +makeProcParam refName = + [ makePreferParam ["params=single-object"] + , (mempty :: Param) + & name .~ "args" + & required ?~ True + & schema .~ ParamBody (Ref (Reference refName)) + ] + +makeDeleteParams :: [Param] +makeDeleteParams = + [ makePreferParam ["return=representation", "return=minimal", "return=none"] ] + +makePathItem :: (Table, [Column], [Text]) -> (FilePath, PathItem) +makePathItem (t, cs, _) = ("/" ++ unpack tn, p $ tableInsertable t) + where + tOp = (mempty :: Operation) + & tags .~ Set.fromList [tn] + & produces ?~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV] + & at 200 ?~ "OK" + getOp = tOp + & parameters .~ map Inline (makeGetParams cs ++ rs) + & at 206 ?~ "Partial Content" + postOp = tOp + & consumes ?~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV] + & parameters .~ map Inline (makePostParams tn) + & at 201 ?~ "Created" + patchOp = tOp + & consumes ?~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV] + & parameters .~ map Inline (makePostParams tn ++ rs) + & at 204 ?~ "No Content" + deletOp = tOp + & parameters .~ map Inline (makeDeleteParams ++ rs) + pr = (mempty :: PathItem) & get ?~ getOp + pw = pr & post ?~ postOp & patch ?~ patchOp & delete ?~ deletOp + p False = pr + p True = pw + rs = makeRowFilters cs + tn = tableName t + +makeProcPathItem :: ProcDescription -> (FilePath, PathItem) +makeProcPathItem pd = ("/rpc/" ++ toS (pdName pd), pe) + where + postOp = (mempty :: Operation) + & parameters .~ map Inline (makeProcParam $ "(rpc) " <> pdName pd) + & tags .~ Set.fromList ["(rpc) " <> pdName pd] + & produces ?~ makeMimeList [CTApplicationJSON, CTSingularJSON] + & at 200 ?~ "OK" + pe = (mempty :: PathItem) & post ?~ postOp + +makeRootPathItem :: (FilePath, PathItem) +makeRootPathItem = ("/", p) + where + getOp = (mempty :: Operation) + & tags .~ Set.fromList ["/"] + & produces ?~ makeMimeList [CTOpenAPI] + & at 200 ?~ "OK" + pr = (mempty :: PathItem) & get ?~ getOp + p = pr + +makePathItems :: [ProcDescription] -> [(Table, [Column], [Text])] -> InsOrdHashMap FilePath PathItem +makePathItems pds ti = fromList $ makeRootPathItem : + map makePathItem ti ++ map makeProcPathItem pds + +escapeHostName :: Text -> Text +escapeHostName "*" = "0.0.0.0" +escapeHostName "*4" = "0.0.0.0" +escapeHostName "!4" = "0.0.0.0" +escapeHostName "*6" = "0.0.0.0" +escapeHostName "!6" = "0.0.0.0" +escapeHostName h = h + +postgrestSpec :: [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Swagger +postgrestSpec pds ti (s, h, p, b) = (mempty :: Swagger) + & basePath ?~ unpack b + & schemes ?~ [s'] + & info .~ ((mempty :: Info) + & version .~ prettyVersion + & title .~ "PostgREST API" + & description ?~ "This is a dynamic API generated by PostgREST") + & host .~ h' + & definitions .~ fromList (map makeTableDef ti <> map makeProcDef pds) + & paths .~ makePathItems pds ti + where + s' = if s == "http" then Http else Https + h' = Just $ Host (unpack $ escapeHostName h) (Just (fromInteger p)) + +encodeOpenAPI :: [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> LByteString +encodeOpenAPI pds ti uri = encode $ postgrestSpec pds ti uri + +{-| + 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 + -- should never happen + -- since the request would have been rejected by the middleware if proxy uri + -- is malformed + | isMalformedProxyUri proxy = Nothing + | otherwise = Just Proxy { + proxyScheme = scheme + , proxyHost = host' + , proxyPort = port'' + , proxyPath = path' + } + where + uri = toURI $ fromJust proxy + scheme = init $ toLower $ pack $ uriScheme uri + path URI {uriPath = ""} = "/" + path URI {uriPath = p} = p + path' = pack $ path uri + authority = fromJust $ uriAuthority uri + host' = pack $ uriRegName authority + port' = uriPort authority + readPort = fromMaybe 80 . readMaybe + port'' :: Integer + port'' = case (port', scheme) of + ("", "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/Parsers.hs b/src/PostgREST/Parsers.hs --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -1,69 +1,68 @@ -module PostgREST.Parsers --- ( parseGetRequest --- ) -where +module PostgREST.Parsers where -import Control.Applicative hiding ((<$>)) -import Data.Monoid -import Data.String.Conversions (cs) -import Data.Text (Text, intercalate) +import Protolude hiding (try, intercalate) +import Control.Monad ((>>)) +import Data.Text (intercalate) +import Data.List (init, last) import Data.Tree import PostgREST.QueryBuilder (operators) import PostgREST.Types import Text.ParserCombinators.Parsec hiding (many, (<|>)) import PostgREST.RangeQuery (NonnegRange,allRange) -pRequestSelect :: Text -> Parser ReadRequest -pRequestSelect rootNodeName = do - fieldTree <- pFieldForest - return $ foldr treeEntry (Node (readQuery, (rootNodeName, Nothing, Nothing)) []) fieldTree - where - readQuery = Select [] [rootNodeName] [] Nothing allRange - treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest - treeEntry (Node fld@((fn, _),_,alias) fldForest) (Node (q, i) rForest) = - case fldForest of - [] -> Node (q {select=fld:select q}, i) rForest - _ -> Node (q, i) newForest - where - newForest = - foldr treeEntry (Node (Select [] [fn] [] Nothing allRange, (fn, Nothing, alias)) []) fldForest:rForest +pRequestSelect :: Text -> Text -> Either ParseError ReadRequest +pRequestSelect rootName selStr = + parse (pReadRequest rootName) ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr) -pRequestFilter :: (String, String) -> Either ParseError (Path, Filter) +pRequestFilter :: (Text, Text) -> Either ParseError (Path, Filter) pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val) where - treePath = parse pTreePath ("failed to parser tree path (" ++ k ++ ")") k - opVal = parse pOpValueExp ("failed to parse filter (" ++ v ++ ")") v + treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k + opVal = parse pOpValueExp ("failed to parse filter (" ++ toS v ++ ")") $ toS v path = fst <$> treePath fld = snd <$> treePath op = fst <$> opVal val = snd <$> opVal -pRequestOrder :: (String, String) -> Either ParseError (Path, [OrderTerm]) -pRequestOrder (k, v) = (,) <$> path <*> ord +pRequestOrder :: (Text, Text) -> Either ParseError (Path, [OrderTerm]) +pRequestOrder (k, v) = (,) <$> path <*> ord' where - treePath = parse pTreePath ("failed to parser tree path (" ++ k ++ ")") k + treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k path = fst <$> treePath - ord = parse pOrder ("failed to parse order (" ++ v ++ ")") v + ord' = parse pOrder ("failed to parse order (" ++ toS v ++ ")") $ toS v -pRequestRange :: (String, NonnegRange) -> Either ParseError (Path, NonnegRange) +pRequestRange :: (ByteString, NonnegRange) -> Either ParseError (Path, NonnegRange) pRequestRange (k, v) = (,) <$> path <*> pure v where - treePath = parse pTreePath ("failed to parser tree path (" ++ k ++ ")") k + treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k path = fst <$> treePath ws :: Parser Text -ws = cs <$> many (oneOf " \t") +ws = toS <$> many (oneOf " \t") lexeme :: Parser a -> Parser a lexeme p = ws *> p <* ws +pReadRequest :: Text -> Parser ReadRequest +pReadRequest rootNodeName = do + fieldTree <- pFieldForest + return $ foldr treeEntry (Node (readQuery, (rootNodeName, Nothing, Nothing)) []) fieldTree + where + readQuery = Select [] [rootNodeName] [] Nothing allRange + treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest + treeEntry (Node fld@((fn, _),_,alias) fldForest) (Node (q, i) rForest) = + case fldForest of + [] -> Node (q {select=fld:select q}, i) rForest + _ -> Node (q, i) newForest + where + newForest = + foldr treeEntry (Node (Select [] [fn] [] Nothing allRange, (fn, Nothing, alias)) []) fldForest:rForest + pTreePath :: Parser (Path,Field) pTreePath = do p <- pFieldName `sepBy1` pDelimiter jp <- optionMaybe pJsonPath - let pp = map cs p - jpp = map cs <$> jp - return (init pp, (last pp, jpp)) + return (init p, (last p, jp)) pFieldForest :: Parser [Tree SelectItem] pFieldForest = pFieldTree `sepBy1` lexeme (char ',') @@ -73,13 +72,13 @@ <|> Node <$> pSelect <*> pure [] pStar :: Parser Text -pStar = cs <$> (string "*" *> pure ("*"::String)) +pStar = toS <$> (string "*" *> pure ("*"::ByteString)) pFieldName :: Parser Text pFieldName = do matches <- (many1 (letter <|> digit <|> oneOf "_") `sepBy1` dash) "field name (* or [a..z0..9_])" - return $ intercalate "-" $ map cs matches + return $ intercalate "-" $ map toS matches where isDash :: GenParser Char st () isDash = try ( char '-' >> notFollowedBy (char '>') ) @@ -88,10 +87,10 @@ pJsonPathStep :: Parser Text -pJsonPathStep = cs <$> try (string "->" *> pFieldName) +pJsonPathStep = toS <$> try (string "->" *> pFieldName) pJsonPath :: Parser [Text] -pJsonPath = (++) <$> many pJsonPathStep <*> ( (:[]) <$> (string "->>" *> pFieldName) ) +pJsonPath = (<>) <$> many pJsonPathStep <*> ( (:[]) <$> (string "->>" *> pFieldName) ) pField :: Parser Field pField = lexeme $ (,) <$> pFieldName <*> optionMaybe pJsonPath @@ -112,25 +111,25 @@ do alias <- optionMaybe ( try(pFieldName <* aliasSeparator) ) fld <- pField - cast <- optionMaybe (string "::" *> many letter) - return (fld, cs <$> cast, alias) + cast' <- optionMaybe (string "::" *> many letter) + return (fld, toS <$> cast', alias) ) <|> do s <- pStar return ((s, Nothing), Nothing, Nothing) pOperator :: Parser Operator -pOperator = cs <$> (pOp "operator (eq, gt, ...)") - where pOp = foldl (<|>) empty $ map (try . string . cs . fst) operators +pOperator = toS <$> (pOp "operator (eq, gt, ...)") + where pOp = foldl (<|>) empty $ map (try . string . toS . fst) operators pValue :: Parser FValue -pValue = VText <$> (cs <$> many anyChar) +pValue = VText <$> (toS <$> many anyChar) pDelimiter :: Parser Char pDelimiter = char '.' "delimiter (.)" pOperatiorWithNegation :: Parser Operator -pOperatiorWithNegation = try ( (<>) <$> ( cs <$> string "not." ) <*> pOperator) <|> pOperator +pOperatiorWithNegation = try ( (<>) <$> ( toS <$> string "not." ) <*> pOperator) <|> pOperator pOpValueExp :: Parser (Operator, FValue) pOpValueExp = (,) <$> pOperatiorWithNegation <*> (pDelimiter *> pValue) @@ -141,14 +140,15 @@ pOrderTerm :: Parser OrderTerm pOrderTerm = try ( do - c <- pFieldName - _ <- pDelimiter - d <- (string "asc" *> pure OrderAsc) - <|> (string "desc" *> pure OrderDesc) + c <- pField + d <- optionMaybe (try $ pDelimiter *> ( + try(string "asc" *> pure OrderAsc) + <|> try(string "desc" *> pure OrderDesc) + )) nls <- optionMaybe (pDelimiter *> ( try(string "nullslast" *> pure OrderNullsLast) <|> try(string "nullsfirst" *> pure OrderNullsFirst) )) return $ OrderTerm c d nls ) - <|> OrderTerm <$> (cs <$> pFieldName) <*> pure OrderAsc <*> pure Nothing + <|> OrderTerm <$> pField <*> pure Nothing <*> pure Nothing diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-| @@ -13,11 +12,10 @@ Any function that outputs a SQL fragment should be in this module. -} module PostgREST.QueryBuilder ( - addRelations - , addJoinConditions - , callProc + callProc , createReadStatement , createWriteStatement + , getJoinConditions , operators , pgFmtIdent , pgFmtLit @@ -33,32 +31,24 @@ import qualified Hasql.Decoders as HD import qualified Data.Aeson as JSON -import Data.Int (Int64) import PostgREST.RangeQuery (NonnegRange, rangeLimit, rangeOffset, allRange) -import Control.Error (note, fromMaybe) import Data.Functor.Contravariant (contramap) import qualified Data.HashMap.Strict as HM -import Data.List (find) -import Data.Monoid ((<>)) -import Data.Text (Text, intercalate, unwords, replace, isInfixOf, toLower, split) +import Data.Text (intercalate, unwords, replace, isInfixOf, toLower, split) import qualified Data.Text as T (map, takeWhile, null) import qualified Data.Text.Encoding as T -import Data.String.Conversions (cs) -import Control.Applicative ((<|>)) -import Control.Monad (replicateM) import Data.Tree (Tree(..)) import qualified Data.Vector as V import PostgREST.Types import qualified Data.Map as M import Text.InterpolatedString.Perl6 (qc) -import Text.Regex.TDFA ((=~)) import qualified Data.ByteString.Char8 as BS import Data.Scientific ( FPFormat (..) , formatScientific , isInteger ) -import Prelude hiding (unwords) +import Protolude hiding (from, intercalate, ord, cast) import PostgREST.ApiRequest (PreferRepresentation (..)) {-| The generic query result format used by API responses. The location header @@ -89,25 +79,25 @@ HD.maybeRow standardRow {-| JSON and CSV payloads from the client are given to us as - UniformObjects (objects who all have the same keys), + PayloadJSON (objects who all have the same keys), and we turn this into an old fasioned JSON array -} -encodeUniformObjs :: HE.Params UniformObjects +encodeUniformObjs :: HE.Params PayloadJSON encodeUniformObjs = - contramap (JSON.Array . V.map JSON.Object . unUniformObjects) (HE.value HE.json) + contramap (JSON.Array . V.map JSON.Object . unPayloadJSON) (HE.value HE.json) createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> H.Query () ResultsWithCount createReadStatement selectQuery countQuery isSingle countTotal asCsv = - unicodeStatement sql HE.unit decodeStandard True + unicodeStatement sql HE.unit decodeStandard False where sql = [qc| WITH {sourceCTEName} AS ({selectQuery}) SELECT {cols} - FROM ( SELECT * FROM {sourceCTEName}) t |] + FROM ( SELECT * FROM {sourceCTEName}) _postgrest_t |] countResultF = if countTotal then "("<>countQuery<>")" else "null" cols = intercalate ", " [ countResultF <> " AS total_result_set", - "pg_catalog.count(t) AS page_total", + "pg_catalog.count(_postgrest_t) AS page_total", noLocationF <> " AS header", bodyF <> " AS body" ] @@ -116,116 +106,78 @@ | isSingle = asJsonSingleF | otherwise = asJsonF -createWriteStatement :: QualifiedIdentifier -> SqlQuery -> SqlQuery -> Bool -> - PreferRepresentation -> [Text] -> Bool -> Payload -> - H.Query UniformObjects (Maybe ResultsWithCount) -createWriteStatement _ _ _ _ _ _ _ (PayloadParseError _) = undefined -createWriteStatement _ _ mutateQuery _ None - _ _ (PayloadJSON (UniformObjects _)) = +createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> + PreferRepresentation -> [Text] -> + H.Query PayloadJSON (Maybe ResultsWithCount) +createWriteStatement selectQuery mutateQuery wantSingle wantHdrs asCsv rep pKeys = unicodeStatement sql encodeUniformObjs decodeStandardMay True + where - sql = [qc| + sql = case rep of + None -> [qc| WITH {sourceCTEName} AS ({mutateQuery}) SELECT '', 0, {noLocationF}, '' |] - -createWriteStatement qi _ mutateQuery isSingle HeadersOnly - pKeys _ (PayloadJSON (UniformObjects _)) = - unicodeStatement sql encodeUniformObjs decodeStandardMay True - where - sql = [qc| - WITH {sourceCTEName} AS ({mutateQuery} RETURNING {fromQi qi}.*) + HeadersOnly -> [qc| + WITH {sourceCTEName} AS ({mutateQuery}) SELECT {cols} - FROM (SELECT 1 FROM {sourceCTEName}) t |] - cols = intercalate ", " [ - "'' AS total_result_set", - "pg_catalog.count(t) AS page_total", - if isSingle then locationF pKeys else noLocationF, - "''" - ] - -createWriteStatement qi selectQuery mutateQuery isSingle Full - pKeys asCsv (PayloadJSON (UniformObjects _)) = - unicodeStatement sql encodeUniformObjs decodeStandardMay True - where - sql = [qc| - WITH {sourceCTEName} AS ({mutateQuery} RETURNING {fromQi qi}.*) + FROM (SELECT 1 FROM {sourceCTEName}) _postgrest_t |] + Full -> [qc| + WITH {sourceCTEName} AS ({mutateQuery}) SELECT {cols} - FROM ({selectQuery}) t |] + FROM ({selectQuery}) _postgrest_t |] + cols = intercalate ", " [ "'' AS total_result_set", -- when updateing it does not make sense - "pg_catalog.count(t) AS page_total", - if isSingle then locationF pKeys else noLocationF <> " AS header", - bodyF <> " AS body" + "pg_catalog.count(_postgrest_t) AS page_total", + if wantHdrs + then locationF pKeys + else noLocationF <> " AS header", + if rep == Full + then bodyF <> " AS body" + else "''" ] + bodyF | asCsv = asCsvF - | isSingle = asJsonSingleF + | wantSingle = asJsonSingleF | otherwise = asJsonF -addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either Text ReadRequest -addRelations schema allRelations parentNode node@(Node readNode@(query, (name, _, alias)) forest) = - case parentNode of - (Just (Node (Select{from=[parentTable]}, (_, _, _)) _)) -> Node <$> (addRel readNode <$> rel) <*> updatedForest - where - rel = note ("no relation between " <> parentTable <> " and " <> name) - $ findRelationByTable schema name parentTable - <|> findRelationByColumn schema parentTable name - addRel :: (ReadQuery, (NodeName, Maybe Relation, Maybe Alias)) -> Relation -> (ReadQuery, (NodeName, Maybe Relation, Maybe Alias)) - addRel (query', (n, _, a)) r = (query' {from=fromRelation}, (n, Just r, a)) - where fromRelation = map (\t -> if t == n then tableName (relTable r) else t) (from query') - - _ -> Node (query, (name, Nothing, alias)) <$> updatedForest - where - updatedForest = mapM (addRelations schema allRelations (Just node)) forest - -- Searches through all the relations and returns a match given the parameter conditions. - -- Will only find a relation where both schemas are in the PostgREST schema. - -- `findRelationByColumn` also does a ducktype check to see if the column name has any variation of `id` or `fk`. If so then the relation is returned as a match. - findRelationByTable s t1 t2 = - find (\r -> s == tableSchema (relTable r) && s == tableSchema (relFTable r) && t1 == tableName (relTable r) && t2 == tableName (relFTable r)) allRelations - findRelationByColumn s t c = - find (\r -> s == tableSchema (relTable r) && s == tableSchema (relFTable r) && t == tableName (relFTable r) && length (relFColumns r) == 1 && c `colMatches` (colName . head . relFColumns) r) allRelations - where n `colMatches` rc = (cs ("^" <> rc <> "_?(?:|[iI][dD]|[fF][kK])$") :: BS.ByteString) =~ (cs n :: BS.ByteString) - -addJoinConditions :: Schema -> ReadRequest -> Either Text ReadRequest -addJoinConditions schema (Node nn@(query, (n, r, a)) forest) = - case r of - Nothing -> Node nn <$> updatedForest -- this is the root node - Just rel@Relation{relType=Child} -> Node (addCond query (getJoinConditions rel),(n,r,a)) <$> updatedForest - Just Relation{relType=Parent} -> Node nn <$> updatedForest - Just rel@Relation{relType=Many, relLTable=(Just linkTable)} -> - Node (qq, (n, r, a)) <$> updatedForest - where - query' = addCond query (getJoinConditions rel) - qq = query'{from=tableName linkTable : from query'} - _ -> Left "unknown relation" - where - updatedForest = mapM (addJoinConditions schema) forest - addCond query' con = query'{flt_=con ++ flt_ query'} - -type ProcResults = (Maybe Int64, Int64, JSON.Value) -callProc :: QualifiedIdentifier -> JSON.Object -> NonnegRange -> Bool -> H.Query () (Maybe ProcResults) -callProc qi params range countTotal = +type ProcResults = (Maybe Int64, Int64, ByteString) +callProc :: QualifiedIdentifier -> JSON.Object -> SqlQuery -> SqlQuery -> NonnegRange -> Bool -> Bool -> Bool -> H.Query () (Maybe ProcResults) +callProc qi params selectQuery countQuery _ countTotal isSingle paramsAsJson = unicodeStatement sql HE.unit decodeProc True where sql = [qc| - WITH t AS (select * {_callSql}) + WITH {sourceCTEName} AS ({_callSql}) SELECT - {_countExpr} as countTotal, - pg_catalog.count(1) as countResult, - array_to_json( - coalesce(array_agg(row_to_json(r)), '\{}') - )::character varying - FROM (select * from t {limitF range}) r; + {countResultF} AS total_result_set, + pg_catalog.count(_postgrest_t) AS page_total, + case + when pg_catalog.count(*) > 1 then + {bodyF} + else + coalesce(((array_agg(row_to_json(_postgrest_t)))[1]->{_procName})::character varying, {bodyF}) + + end as body + FROM ({selectQuery}) _postgrest_t; |] - _args = intercalate "," $ map _assignment (HM.toList params) + -- FROM (select * from {sourceCTEName} {limitF range}) t; + countResultF = if countTotal then "("<>countQuery<>")" else "null::bigint" :: Text + _args = if paramsAsJson + then insertableValueWithType "json" $ JSON.Object params + else intercalate "," $ map _assignment (HM.toList params) + _procName = pgFmtLit $ qiName qi _assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v - _callSql = [qc| from {fromQi qi}({_args}) |] :: Text + _callSql = [qc|select * from {fromQi qi}({_args}) |] :: Text _countExpr = if countTotal - then "(select pg_catalog.count(1) from t)" + then [qc|(select pg_catalog.count(*) from {sourceCTEName})|] else "null::bigint" :: Text decodeProc = HD.maybeRow procRow procRow = (,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8 - <*> HD.value HD.json + <*> HD.value HD.bytea + bodyF + | isSingle = asJsonSingleF + | otherwise = asJsonF operators :: [(Text, SqlFragment)] operators = [ @@ -247,7 +199,7 @@ ] pgFmtIdent :: SqlFragment -> SqlFragment -pgFmtIdent x = "\"" <> replace "\"" "\"\"" (trimNullChars $ cs x) <> "\"" +pgFmtIdent x = "\"" <> replace "\"" "\"\"" (trimNullChars $ toS x) <> "\"" pgFmtLit :: SqlFragment -> SqlFragment pgFmtLit x = @@ -262,22 +214,23 @@ requestToCountQuery _ (DbMutate _) = undefined requestToCountQuery schema (DbRead (Node (Select _ _ conditions _ _, (mainTbl, _, _)) _)) = unwords [ - "SELECT pg_catalog.count(1)", - "FROM ", fromQi $ QualifiedIdentifier schema mainTbl, - ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl)) localConditions )) `emptyOnNull` localConditions + "SELECT pg_catalog.count(*)", + "FROM ", fromQi qi, + ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi) localConditions )) `emptyOnNull` localConditions ] where + qi = if mainTbl == sourceCTEName + then QualifiedIdentifier "" mainTbl + else QualifiedIdentifier schema mainTbl fn Filter{value=VText _} = True fn Filter{value=VForeignKey _ _} = False localConditions = filter fn conditions -requestToQuery :: Schema -> DbRequest -> SqlQuery -requestToQuery _ (DbMutate (Insert _ (PayloadParseError _))) = undefined -requestToQuery _ (DbMutate (Update _ (PayloadParseError _) _)) = undefined -requestToQuery schema (DbRead (Node (Select colSelects tbls conditions ord range, (nodeName, maybeRelation, _)) forest)) = +requestToQuery :: Schema -> Bool -> DbRequest -> SqlQuery +requestToQuery schema isParent (DbRead (Node (Select colSelects tbls conditions ord range, (nodeName, maybeRelation, _)) forest)) = query where - -- TODO! the folloing helper functions are just to remove the "schema" part when the table is "source" which is the name + -- TODO! the following helper functions are just to remove the "schema" part when the table is "source" which is the name -- of our WITH query part mainTbl = fromMaybe nodeName (tableName . relTable <$> maybeRelation) tblSchema tbl = if tbl == sourceCTEName then "" else schema @@ -289,7 +242,7 @@ unwords joins, ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions, orderF (fromMaybe [] ord), - limitF range + if isParent then "" else limitF range ] orderF ts = if null ts @@ -299,9 +252,9 @@ clause = intercalate "," (map queryTerm ts) queryTerm :: OrderTerm -> Text queryTerm t = " " - <> cs (pgFmtColumn qi $ otTerm t) <> " " - <> (cs.show) (otDirection t) <> " " - <> maybe "" (cs.show) (otNullOrder t) <> " " + <> toS (pgFmtField qi $ otTerm t) <> " " + <> maybe "" show (otDirection t) <> " " + <> maybe "" show (otNullOrder t) <> " " (joins, selects) = foldr getQueryParts ([],[]) forest getQueryParts :: Tree ReadNode -> ([SqlFragment], [SqlFragment]) -> ([SqlFragment], [SqlFragment]) @@ -311,7 +264,7 @@ <> "SELECT array_to_json(array_agg(row_to_json("<>pgFmtIdent table<>"))) " <> "FROM (" <> subquery <> ") " <> pgFmtIdent table <> "), '[]') AS " <> pgFmtIdent (fromMaybe name alias) - where subquery = requestToQuery schema (DbRead (Node n forst)) + where subquery = requestToQuery schema False (DbRead (Node n forst)) getQueryParts (Node n@(_, (name, Just r@Relation{relType=Parent,relTable=Table{tableName=table}}, alias)) forst) (j,s) = (joi:j,sel:s) where node_name = fromMaybe name alias @@ -321,31 +274,34 @@ sel = "row_to_json(" <> pgFmtIdent local_table_name <> ".*) AS " <> pgFmtIdent node_name joi = " LEFT OUTER JOIN ( " <> subquery <> " ) AS " <> pgFmtIdent local_table_name <> " ON " <> intercalate " AND " ( map (pgFmtCondition qi . replaceTableName local_table_name) (getJoinConditions r) ) - where subquery = requestToQuery schema (DbRead (Node n forst)) + where subquery = requestToQuery schema True (DbRead (Node n forst)) getQueryParts (Node n@(_, (name, Just Relation{relType=Many,relTable=Table{tableName=table}}, alias)) forst) (j,s) = (j,sel:s) where sel = "COALESCE ((" <> "SELECT array_to_json(array_agg(row_to_json("<>pgFmtIdent table<>"))) " <> "FROM (" <> subquery <> ") " <> pgFmtIdent table <> "), '[]') AS " <> pgFmtIdent (fromMaybe name alias) - where subquery = requestToQuery schema (DbRead (Node n forst)) + where subquery = requestToQuery schema False (DbRead (Node n forst)) --the following is just to remove the warning --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only --posible relations are Child Parent Many - getQueryParts (Node (_,(_,Nothing,_)) _) _ = undefined -requestToQuery schema (DbMutate (Insert mainTbl (PayloadJSON (UniformObjects rows)))) = - let qi = QualifiedIdentifier schema mainTbl - cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0)) - colsString = intercalate ", " cols - insInto = unwords [ "INSERT INTO" , fromQi qi, - if T.null colsString then "" else "(" <> colsString <> ")" - ] - vals = unwords $ if T.null colsString - then ["DEFAULT VALUES"] - else ["SELECT", colsString, "FROM json_populate_recordset(null::" , fromQi qi, ", $1)"] in - insInto <> vals - -requestToQuery schema (DbMutate (Update mainTbl (PayloadJSON (UniformObjects rows)) conditions)) = + getQueryParts _ _ = undefined +requestToQuery schema _ (DbMutate (Insert mainTbl (PayloadJSON rows) returnings)) = + insInto <> vals <> ret + where qi = QualifiedIdentifier schema mainTbl + cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0)) + colsString = intercalate ", " cols + insInto = unwords [ "INSERT INTO" , fromQi qi, + if T.null colsString then "" else "(" <> colsString <> ")" + ] + vals = unwords $ + if T.null colsString + then if V.null rows then ["SELECT null WHERE false"] else ["DEFAULT VALUES"] + else ["SELECT", colsString, "FROM json_populate_recordset(null::" , fromQi qi, ", $1)"] + ret = if null returnings + then "" + else unwords [" RETURNING ", intercalate ", " (map (pgFmtColumn qi) returnings)] +requestToQuery schema _ (DbMutate (Update mainTbl (PayloadJSON rows) conditions returnings)) = case rows V.!? 0 of Just obj -> let assignments = map @@ -353,18 +309,20 @@ unwords [ "UPDATE ", fromQi qi, " SET " <> intercalate "," assignments <> " ", - ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions + ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions, + ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnNull` returnings ] Nothing -> undefined where qi = QualifiedIdentifier schema mainTbl -requestToQuery schema (DbMutate (Delete mainTbl conditions)) = +requestToQuery schema _ (DbMutate (Delete mainTbl conditions returnings)) = query where qi = QualifiedIdentifier schema mainTbl query = unwords [ "DELETE FROM ", fromQi qi, - ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions + ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions, + ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnNull` returnings ] sourceCTEName :: SqlFragment @@ -373,9 +331,9 @@ unquoted :: JSON.Value -> Text unquoted (JSON.String t) = t unquoted (JSON.Number n) = - cs $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n -unquoted (JSON.Bool b) = cs . show $ b -unquoted v = cs $ JSON.encode v + toS $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n +unquoted (JSON.Bool b) = show b +unquoted v = toS $ JSON.encode v -- private functions asCsvF :: SqlFragment @@ -390,13 +348,13 @@ " ) s" <> " ) a" <> ")" - asCsvBodyF = "coalesce(string_agg(substring(t::text, 2, length(t::text) - 2), '\n'), '')" + asCsvBodyF = "coalesce(string_agg(substring(_postgrest_t::text, 2, length(_postgrest_t::text) - 2), '\n'), '')" asJsonF :: SqlFragment -asJsonF = "coalesce(array_to_json(array_agg(row_to_json(t))), '[]')::character varying" +asJsonF = "coalesce(array_to_json(array_agg(row_to_json(_postgrest_t))), '[]')::character varying" asJsonSingleF :: SqlFragment --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element -asJsonSingleF = "coalesce(string_agg(row_to_json(t)::text, ','), '')::character varying " +asJsonSingleF = "coalesce(string_agg(row_to_json(_postgrest_t)::text, ','), '')::character varying " locationF :: [Text] -> SqlFragment locationF pKeys = @@ -415,8 +373,8 @@ then "" else "LIMIT " <> limit <> " OFFSET " <> offset where - limit = maybe "ALL" (cs . show) $ rangeLimit r - offset = cs . show $ rangeOffset r + limit = maybe "ALL" show $ rangeLimit r + offset = show $ rangeOffset r fromQi :: QualifiedIdentifier -> SqlFragment fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n @@ -430,6 +388,7 @@ Child -> zipWith (toFilter tN ftN) cols fcs Parent -> zipWith (toFilter tN ftN) cols fcs Many -> zipWith (toFilter tN ltN) cols (fromMaybe [] lc1) ++ zipWith (toFilter ftN ltN) fcs (fromMaybe [] lc2) + Root -> undefined --error "undefined getJoinConditions" where s = if typ == Parent then "" else tableSchema t tN = tableName t @@ -448,9 +407,13 @@ insertableValue JSON.Null = "null" insertableValue v = (<> "::unknown") . pgFmtLit $ unquoted v +insertableValueWithType :: Text -> JSON.Value -> SqlFragment +insertableValueWithType t v = + pgFmtLit (unquoted v) <> "::" <> t + whiteList :: Text -> SqlFragment whiteList val = fromMaybe - (cs (pgFmtLit val) <> "::unknown ") + (toS (pgFmtLit val) <> "::unknown ") (find ((==) . toLower $ val) ["null","true","false"]) pgFmtColumn :: QualifiedIdentifier -> Text -> SqlFragment @@ -471,7 +434,7 @@ where headPredicate:rest = split (=='.') ops hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse - opCode = hasNot (head rest) headPredicate + opCode = hasNot (headDef "eq" rest) headPredicate notOp = hasNot headPredicate "" sqlCol = case val of VText _ -> pgFmtColumn table col <> pgFmtJsonPath jp @@ -511,7 +474,9 @@ pgFmtAs :: Maybe JsonPath -> Maybe Alias -> SqlFragment pgFmtAs Nothing Nothing = "" -pgFmtAs (Just xx) Nothing = " AS " <> pgFmtIdent (last xx) +pgFmtAs (Just xx) Nothing = case lastMay xx of + Just alias -> " AS " <> pgFmtIdent alias + Nothing -> "" pgFmtAs _ (Just alias) = " AS " <> pgFmtIdent alias trimNullChars :: Text -> Text diff --git a/src/PostgREST/RangeQuery.hs b/src/PostgREST/RangeQuery.hs --- a/src/PostgREST/RangeQuery.hs +++ b/src/PostgREST/RangeQuery.hs @@ -17,13 +17,11 @@ import Data.Ranged.Boundaries import Data.Ranged.Ranges -import Data.String.Conversions (cs) -import Text.Read (readMaybe) import Text.Regex.TDFA ((=~)) -import Data.Maybe (fromMaybe, listToMaybe) +import Data.List (lookup) -import Prelude +import Protolude type NonnegRange = Range Integer @@ -33,9 +31,9 @@ case listToMaybe (range =~ rangeRegex :: [[BS.ByteString]]) of Just parsedRange -> - let [_, from, to] = readMaybe . cs <$> parsedRange - lower = fromMaybe emptyRange (rangeGeq <$> from) - upper = fromMaybe allRange (rangeLeq <$> to) in + let [_, mLower, mUpper] = readMaybe . toS <$> parsedRange + lower = fromMaybe emptyRange (rangeGeq <$> mLower) + upper = fromMaybe allRange (rangeLeq <$> mUpper) in rangeIntersection lower upper Nothing -> allRange @@ -52,14 +50,14 @@ rangeLimit :: NonnegRange -> Maybe Integer rangeLimit range = case [rangeLower range, rangeUpper range] of - [BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from) + [BoundaryBelow lower, BoundaryAbove upper] -> Just (1 + upper - lower) _ -> Nothing rangeOffset :: NonnegRange -> Integer rangeOffset range = case rangeLower range of - BoundaryBelow from -> from - _ -> error "range without lower bound" -- should never happen + BoundaryBelow lower -> lower + _ -> panic "range without lower bound" -- should never happen rangeGeq :: Integer -> NonnegRange rangeGeq n = diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -1,9 +1,8 @@ module PostgREST.Types where +import Protolude +import qualified GHC.Show import Data.Aeson -import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL -import Data.Int (Int32) -import Data.Text import Data.Tree import qualified Data.Vector as V import PostgREST.RangeQuery (NonnegRange) @@ -13,8 +12,21 @@ , dbColumns :: [Column] , dbRelations :: [Relation] , dbPrimaryKeys :: [PrimaryKey] +, dbProcs :: [(Text,ProcDescription)] } deriving (Show, Eq) +data PgArg = PgArg { + pgaName :: Text +, pgaType :: Text +, pgaReq :: Bool +} deriving (Show, Eq) + +data ProcDescription = ProcDescription { + pdName :: Text +, pdArgs :: [PgArg] +, pdReturnType :: Text +} deriving (Show, Eq) + type Schema = Text type TableName = Text type SqlQuery = Text @@ -64,8 +76,8 @@ show OrderNullsLast = "nulls last" data OrderTerm = OrderTerm { - otTerm :: Text -, otDirection :: OrderDirection + otTerm :: Field +, otDirection :: Maybe OrderDirection , otNullOrder :: Maybe OrderNulls } deriving (Show, Eq) @@ -75,7 +87,7 @@ } deriving (Show, Eq) -data RelationType = Child | Parent | Many deriving (Show, Eq) +data RelationType = Child | Parent | Many | Root deriving (Show, Eq) data Relation = Relation { relTable :: Table , relColumns :: [Column] @@ -89,18 +101,18 @@ -- | An array of JSON objects that has been verified to have -- the same keys in every object -newtype UniformObjects = UniformObjects (V.Vector Object) +newtype PayloadJSON = PayloadJSON (V.Vector Object) deriving (Show, Eq) -unUniformObjects :: UniformObjects -> V.Vector Object -unUniformObjects (UniformObjects objs) = objs +unPayloadJSON :: PayloadJSON -> V.Vector Object +unPayloadJSON (PayloadJSON objs) = objs --- | When Hasql supports the COPY command then we can --- have a special payload just for CSV, but until --- then CSV is converted to a JSON array. -data Payload = PayloadJSON UniformObjects - | PayloadParseError BS.ByteString - deriving (Show, Eq) +data Proxy = Proxy { + proxyScheme :: Text +, proxyHost :: Text +, proxyPort :: Integer +, proxyPath :: Text +} deriving (Show, Eq) type Operator = Text data FValue = VText Text | VForeignKey QualifiedIdentifier ForeignKey deriving (Show, Eq) @@ -113,9 +125,9 @@ type SelectItem = (Field, Maybe Cast, Maybe Alias) type Path = [Text] data ReadQuery = Select { select::[SelectItem], from::[TableName], flt_::[Filter], order::Maybe [OrderTerm], range_::NonnegRange } deriving (Show, Eq) -data MutateQuery = Insert { in_::TableName, qPayload::Payload } - | Delete { in_::TableName, where_::[Filter] } - | Update { in_::TableName, qPayload::Payload, where_::[Filter] } deriving (Show, Eq) +data MutateQuery = Insert { in_::TableName, qPayload::PayloadJSON, returning::[FieldName] } + | Delete { in_::TableName, where_::[Filter], returning::[FieldName] } + | Update { in_::TableName, qPayload::PayloadJSON, where_::[Filter], returning::[FieldName] } deriving (Show, Eq) data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq) type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias)) type ReadRequest = Tree ReadNode diff --git a/test/Feature/AuthSpec.hs b/test/Feature/AuthSpec.hs --- a/test/Feature/AuthSpec.hs +++ b/test/Feature/AuthSpec.hs @@ -1,6 +1,7 @@ module Feature.AuthSpec where -- {{{ Imports +import Text.Heredoc import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON @@ -8,10 +9,13 @@ import SpecHelper import Network.Wai (Application) + +import Protolude hiding (get) -- }}} spec :: SpecWith Application spec = describe "authorization" $ do + let single = ("Accept","application/vnd.pgrst.object+json") it "denies access to tables that anonymous does not own" $ get "/authors_only" `shouldRespondWith` ResponseMatcher { @@ -38,17 +42,18 @@ } it "returns jwt functions as jwt tokens" $ - post "/rpc/login" [json| { "id": "jdoe", "pass": "1234" } |] + request methodPost "/rpc/login" [single] + [json| { "id": "jdoe", "pass": "1234" } |] `shouldRespondWith` ResponseMatcher { - matchBody = Just [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"} |] + matchBody = Just [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xuYW1lIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.P2G9EVSVI22MWxXWFuhEYd9BZerLS1WDlqzdqplM15s"} |] , matchStatus = 200 , matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"] } it "sql functions can encode custom and standard claims" $ - post "/rpc/jwt_test" "{}" + request methodPost "/rpc/jwt_test" [single] "{}" `shouldRespondWith` ResponseMatcher { - matchBody = Just [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJzdWIiOiJmdW4iLCJqdGkiOiJmb28iLCJuYmYiOjEzMDA4MTkzODAsImV4cCI6MTMwMDgxOTM4MCwiaHR0cDovL3Bvc3RncmVzdC5jb20vZm9vIjp0cnVlLCJpc3MiOiJqb2UiLCJyb2xlIjoicG9zdGdyZXN0X3Rlc3QiLCJpYXQiOjEzMDA4MTkzODAsImF1ZCI6ImV2ZXJ5b25lIn0._tQCF79-ZZGMlLktd3csM_bVaiMg7A8YvIb6K2hcu5w"} |] + matchBody = Just [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpc3MiOiJqb2UiLCJzdWIiOiJmdW4iLCJhdWQiOiJldmVyeW9uZSIsImV4cCI6MTMwMDgxOTM4MCwibmJmIjoxMzAwODE5MzgwLCJpYXQiOjEzMDA4MTkzODAsImp0aSI6ImZvbyIsInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdCIsImh0dHA6Ly9wb3N0Z3Jlc3QuY29tL2ZvbyI6dHJ1ZX0.IHF16ZSU6XTbOnUWO8CCpUn2fJwt8P00rlYVyXQjpWc"} |] , matchStatus = 200 , matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"] } @@ -56,10 +61,7 @@ it "sql functions can read custom and standard claims variables" $ do let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJzdWIiOiJmdW4iLCJqdGkiOiJmb28iLCJuYmYiOjEzMDA4MTkzODAsImV4cCI6OTk5OTk5OTk5OSwiaHR0cDovL3Bvc3RncmVzdC5jb20vZm9vIjp0cnVlLCJpc3MiOiJqb2UiLCJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWF0IjoxMzAwODE5MzgwLCJhdWQiOiJldmVyeW9uZSJ9.AQmCA7CMScvfaDRMqRPeUY6eNf--69gpW-kxaWfq9X0" request methodPost "/rpc/reveal_big_jwt" [auth] "{}" - `shouldRespondWith` [json| [ - {"sub":"fun", "jti":"foo", "nbf":1300819380, "exp":9999999999, - "http://postgrest.com/foo":true, "iss":"joe", "iat":1300819380, - "aud":"everyone"}] |] + `shouldRespondWith` [str|[{"iss":"joe","sub":"fun","aud":"everyone","exp":9999999999,"nbf":1300819380,"iat":1300819380,"jti":"foo","http://postgrest.com/foo":true}]|] it "allows users with permissions to see their tables" $ do let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0" @@ -80,26 +82,72 @@ it "fails with an expired token" $ do let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjE0NDY2NzgxNDksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.enk_qZ_u6gZsXY4R8bREKB_HNExRpM0lIWSLktk9JJQ" request methodGet "/authors_only" [auth] "" - `shouldRespondWith` 400 + `shouldRespondWith` ResponseMatcher { + matchBody = Nothing + , matchStatus = 401 + , matchHeaders = [ + "WWW-Authenticate" <:> + "Bearer error=\"invalid_token\", error_description=\"JWT expired\"" + ] + } it "hides tables from users with invalid JWT" $ do let auth = authHeaderJWT "ey9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0" request methodGet "/authors_only" [auth] "" - `shouldRespondWith` 400 + `shouldRespondWith` ResponseMatcher { + matchBody = Nothing + , matchStatus = 401 + , matchHeaders = [ + "WWW-Authenticate" <:> + "Bearer error=\"invalid_token\", error_description=\"JWT invalid\"" + ] + } it "should fail when jwt contains no claims" $ do - let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.e30.MKYc_lOECtB0LJOiykilAdlHodB-I0_id2qHKq35dmc" + let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.e30.lu-rG8aSCiw-aOlN0IxpRGz5r7Jwq7K9r3tuMPUpytI" request methodGet "/authors_only" [auth] "" - `shouldRespondWith` 400 + `shouldRespondWith` 401 it "hides tables from users with JWT that contain no claims about role" $ do - let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6Impkb2UifQ.zyohGMnrDy4_8eJTl6I2AUXO3MeCCiwR24aGWRkTE9o" + let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6Impkb2UifQ.Jneso9X519Vh0z7i9PbXIu7W1HEoq9RRw9BBbyQKFCQ" request methodGet "/authors_only" [auth] "" - `shouldRespondWith` 400 + `shouldRespondWith` 401 - it "recovers after 400 error with logged in user" $ do + it "recovers after 401 error with logged in user" $ do _ <- post "/authors_only" [json| { "owner": "jdoe", "secret": "test content" } |] let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0" _ <- request methodPost "/rpc/problem" [auth] "" request methodGet "/authors_only" [auth] "" `shouldRespondWith` 200 + + describe "custom pre-request proc acting on id claim" $ do + + it "able to switch to postgrest_test_author role (id=1)" $ + let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6MX0.mI2HNoOum6xM3sc4oHLxU4yLv-_WV5W1kqBfY_wEvLw" in + request methodPost "/rpc/get_current_user" [auth] + [json| {} |] + `shouldRespondWith` ResponseMatcher { + matchBody = Just [str|"postgrest_test_author"|] + , matchStatus = 200 + , matchHeaders = [] + } + + it "able to switch to postgrest_test_default_role (id=2)" $ + let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6Mn0.W7jLsG-zswM91AJkCvZeIMHrnz7_6ceY2jnscVl3Yhk" in + request methodPost "/rpc/get_current_user" [auth] + [json| {} |] + `shouldRespondWith` ResponseMatcher { + matchBody = Just [str|"postgrest_test_default_role"|] + , matchStatus = 200 + , matchHeaders = [] + } + + it "raises error (id=3)" $ + let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6M30.15Gy8PezQhJIaHYDJVLa-Gmz9T3sJnW66EKAYIsXc7c" in + request methodPost "/rpc/get_current_user" [auth] + [json| {} |] + `shouldRespondWith` ResponseMatcher { + matchBody = Just [str|{"hint":"Please contact administrator","details":null,"code":"P0001","message":"Disabled ID --> 3"}|] + , matchStatus = 400 + , matchHeaders = [] + } diff --git a/test/Feature/BinaryJwtSecretSpec.hs b/test/Feature/BinaryJwtSecretSpec.hs new file mode 100644 --- /dev/null +++ b/test/Feature/BinaryJwtSecretSpec.hs @@ -0,0 +1,21 @@ +module Feature.BinaryJwtSecretSpec where + +-- {{{ Imports +import Test.Hspec +import Test.Hspec.Wai +import Network.HTTP.Types + +import SpecHelper +import Network.Wai (Application) + +import Protolude hiding (get) +-- }}} + +spec :: SpecWith Application +spec = describe "server started with binary JWT secret" $ + + -- this test will stop working 9999999999s after the UNIX EPOCH + it "succeeds with jwt token encoded with a binary secret" $ do + let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjk5OTk5OTk5OTksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.l_EcSRWeNtL4OKUTIplrHyioNrff9Rd0MV7RXNCxCyk" + request methodGet "/authors_only" [auth] "" + `shouldRespondWith` 200 diff --git a/test/Feature/ConcurrentSpec.hs b/test/Feature/ConcurrentSpec.hs --- a/test/Feature/ConcurrentSpec.hs +++ b/test/Feature/ConcurrentSpec.hs @@ -16,6 +16,8 @@ import Network.Wai (Application) +import Protolude hiding (get) + spec :: SpecWith Application spec = describe "Queryiny in parallel" $ diff --git a/test/Feature/CorsSpec.hs b/test/Feature/CorsSpec.hs --- a/test/Feature/CorsSpec.hs +++ b/test/Feature/CorsSpec.hs @@ -10,6 +10,8 @@ import Network.HTTP.Types import Network.Wai (Application) + +import Protolude hiding (get) -- }}} spec :: SpecWith Application @@ -69,4 +71,4 @@ liftIO $ do simpleHeaders r `shouldSatisfy` matchHeader "Access-Control-Allow-Origin" "\\*" - simpleBody r `shouldSatisfy` not . BL.null + simpleBody r `shouldSatisfy` BL.null diff --git a/test/Feature/DeleteSpec.hs b/test/Feature/DeleteSpec.hs --- a/test/Feature/DeleteSpec.hs +++ b/test/Feature/DeleteSpec.hs @@ -7,6 +7,8 @@ import Network.HTTP.Types import Network.Wai (Application) +import Protolude hiding (get) + spec :: SpecWith Application spec = describe "Deleting" $ do @@ -16,11 +18,11 @@ `shouldRespondWith` ResponseMatcher { matchBody = Nothing , matchStatus = 204 - , matchHeaders = ["Content-Range" <:> "*/1"] + , matchHeaders = ["Content-Range" <:> "*/*"] } - it "returns the deleted item" $ - request methodDelete "/items?id=eq.2" [("Prefer", "return=representation")] "" + it "returns the deleted item and count if requested" $ + request methodDelete "/items?id=eq.2" [("Prefer", "return=representation"), ("Prefer", "count=exact")] "" `shouldRespondWith` ResponseMatcher { matchBody = Just [str|[{"id":2}]|] , matchStatus = 200 @@ -31,14 +33,17 @@ `shouldRespondWith` ResponseMatcher { matchBody = Just [str|[{"id":2,"name":"Two"}]|] , matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "*/1"] + , matchHeaders = ["Content-Range" <:> "*/*"] } + it "can rename and cast the selected columns" $ + request methodDelete "/complex_items?id=eq.3&select=ciId:id::text,ciName:name" [("Prefer", "return=representation")] "" + `shouldRespondWith` [str|[{"ciId":"3","ciName":"Three"}]|] it "can embed (parent) entities" $ request methodDelete "/tasks?id=eq.8&select=id,name,project{id}" [("Prefer", "return=representation")] "" `shouldRespondWith` ResponseMatcher { matchBody = Just [str|[{"id":8,"name":"Code OSX","project":{"id":4}}]|] , matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "*/1"] + , matchHeaders = ["Content-Range" <:> "*/*"] } it "actually clears items ouf the db" $ do @@ -47,12 +52,18 @@ `shouldRespondWith` ResponseMatcher { matchBody = Just [str|[{"id":15}]|] , matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-0/1"] + , matchHeaders = ["Content-Range" <:> "0-0/*"] } - context "known route, unknown record" $ - it "fails with 404" $ - request methodDelete "/items?id=eq.101" [] "" `shouldRespondWith` 404 + context "known route, no records matched" $ + it "includes [] body if return=rep" $ + request methodDelete "/items?id=eq.101" + [("Prefer", "return=representation")] "" + `shouldRespondWith` ResponseMatcher { + matchBody = Just "[]" + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "*/*"] + } context "totally unknown route" $ it "fails with 404" $ diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -8,8 +8,8 @@ import SpecHelper import qualified Data.Aeson as JSON +import Data.List (lookup) import Data.Maybe (fromJust) -import Data.Monoid ((<>)) import Text.Heredoc import Network.HTTP.Types.Header import Network.HTTP.Types @@ -18,6 +18,8 @@ import TestTypes(IncPK(..), CompoundPK(..)) import Network.Wai (Application) +import Protolude hiding (get) + spec :: SpecWith Application spec = do describe "Posting new record" $ do @@ -37,24 +39,39 @@ it "filters columns in result using &select" $ request methodPost "/menagerie?select=integer,varchar" [("Prefer", "return=representation")] - [json| { + [json| [{ "integer": 14, "double": 3.14159, "varchar": "testing!" , "boolean": false, "date": "1900-01-01", "money": "$3.99" , "enum": "foo" - } |] `shouldRespondWith` ResponseMatcher { - matchBody = Just [str|{"integer":14,"varchar":"testing!"}|] + }] |] `shouldRespondWith` ResponseMatcher { + matchBody = Just [str|[{"integer":14,"varchar":"testing!"}]|] , matchStatus = 201 , matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"] } + context "requesting full representation" $ do it "includes related data after insert" $ - request methodPost "/projects?select=id,name,clients{id,name}" [("Prefer", "return=representation")] + request methodPost "/projects?select=id,name,clients{id,name}" + [("Prefer", "return=representation"), ("Prefer", "count=exact")] [str|{"id":6,"name":"New Project","client_id":2}|] `shouldRespondWith` ResponseMatcher { - matchBody = Just [str|{"id":6,"name":"New Project","clients":{"id":2,"name":"Apple"}}|] + matchBody = Just [str|[{"id":6,"name":"New Project","clients":{"id":2,"name":"Apple"}}]|] , matchStatus = 201 - , matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8", "Location" <:> "/projects?id=eq.6"] + , matchHeaders = [ "Content-Type" <:> "application/json; charset=utf-8" + , "Location" <:> "/projects?id=eq.6" + , "Content-Range" <:> "*/1" ] } + it "can rename and cast the selected columns" $ + request methodPost "/projects?select=pId:id::text,pName:name,cId:client_id::text" + [("Prefer", "return=representation")] + [str|{"id":7,"name":"New Project","client_id":2}|] `shouldRespondWith` ResponseMatcher { + matchBody = Just [str|[{"pId":"7","pName":"New Project","cId":"2"}]|] + , matchStatus = 201 + , matchHeaders = [ "Content-Type" <:> "application/json; charset=utf-8" + , "Location" <:> "/projects?id=eq.7" + , "Content-Range" <:> "*/*" ] + } + context "from an html form" $ it "accepts disparate json types" $ do p <- request methodPost "/menagerie" @@ -81,9 +98,11 @@ incNullableStr record `shouldBe` Nothing context "into a table with simple pk" $ - it "fails with 400 and error" $ - post "/simple_pk" [json| { "extra":"foo"} |] - `shouldRespondWith` 400 + it "fails with 400 and error" $ do + p <- post "/simple_pk" [json| { "extra":"foo"} |] + liftIO $ do + simpleStatus p `shouldBe` badRequest400 + isErrorFormat (simpleBody p) `shouldBe` True context "into a table with no pk" $ do it "succeeds with 201 and a link including all fields" $ do @@ -98,10 +117,18 @@ [("Prefer", "return=representation")] [json| { "a":"bar", "b":"baz" } |] liftIO $ do - simpleBody p `shouldBe` [json| { "a":"bar", "b":"baz" } |] + simpleBody p `shouldBe` [json| [{ "a":"bar", "b":"baz" }] |] simpleHeaders p `shouldSatisfy` matchHeader hLocation "/no_pk\\?a=eq.bar&b=eq.baz" simpleStatus p `shouldBe` created201 + it "returns empty array when no items inserted, and return=rep" $ do + p <- request methodPost "/no_pk" + [("Prefer", "return=representation")] + [json| [] |] + liftIO $ do + simpleBody p `shouldBe` [json| [] |] + simpleStatus p `shouldBe` created201 + it "can insert in tables with no select privileges" $ do p <- request methodPost "/insertonly" [("Prefer", "return=minimal")] @@ -116,7 +143,7 @@ [("Prefer", "return=representation")] [json| { "a":null, "b":"foo" } |] liftIO $ do - simpleBody p `shouldBe` [json| { "a":null, "b":"foo" } |] + simpleBody p `shouldBe` [json| [{ "a":null, "b":"foo" }] |] simpleHeaders p `shouldSatisfy` matchHeader hLocation "/no_pk\\?a=is.null&b=eq.foo" simpleStatus p `shouldBe` created201 @@ -129,7 +156,7 @@ [("Prefer", "return=representation")] inserted liftIO $ do - JSON.decode (simpleBody p) `shouldBe` Just expectedObj + JSON.decode (simpleBody p) `shouldBe` Just [expectedObj] simpleStatus p `shouldBe` created201 lookup hLocation (simpleHeaders p) `shouldBe` Just expectedLoc @@ -149,8 +176,11 @@ lookup hLocation (simpleHeaders p) `shouldBe` Nothing context "with invalid json payload" $ - it "fails with 400 and error" $ - post "/simple_pk" "}{ x = 2" `shouldRespondWith` 400 + it "fails with 400 and error" $ do + p <- post "/simple_pk" "}{ x = 2" + liftIO $ do + simpleStatus p `shouldBe` badRequest400 + isErrorFormat (simpleBody p) `shouldBe` True context "with valid json payload" $ it "succeeds and returns 201 created" $ @@ -172,7 +202,7 @@ [("Prefer", "return=representation")] inserted `shouldRespondWith` ResponseMatcher { - matchBody = Just inserted + matchBody = Just [str|[{"data":{"foo":"bar"}}]|] , matchStatus = 201 , matchHeaders = ["Location" <:> location] } @@ -184,7 +214,7 @@ [("Prefer", "return=representation")] inserted `shouldRespondWith` ResponseMatcher { - matchBody = Just inserted + matchBody = Just [str|[{"data":[1,2,3]}]|] , matchStatus = 201 , matchHeaders = ["Location" <:> location] } @@ -196,6 +226,28 @@ , matchStatus = 201 , matchHeaders = [] } + context "table with limited privileges" $ do + it "succeeds if correct select is applied" $ + request methodPost "/limited_article_stars?select=article_id,user_id" [("Prefer", "return=representation")] + [json| {"article_id": 2, "user_id": 1} |] `shouldRespondWith` ResponseMatcher { + matchBody = Just [str|[{"article_id":2,"user_id":1}]|] + , matchStatus = 201 + , matchHeaders = [] + } + it "fails if more columns are selected" $ + request methodPost "/limited_article_stars?select=article_id,user_id,created_at" [("Prefer", "return=representation")] + [json| {"article_id": 2, "user_id": 2} |] `shouldRespondWith` ResponseMatcher { + matchBody = Just [str|{"hint":null,"details":null,"code":"42501","message":"permission denied for relation limited_article_stars"}|] + , matchStatus = 401 + , matchHeaders = [] + } + it "fails if select is not specified" $ + request methodPost "/limited_article_stars" [("Prefer", "return=representation")] + [json| {"article_id": 3, "user_id": 1} |] `shouldRespondWith` ResponseMatcher { + matchBody = Just [str|{"hint":null,"details":null,"code":"42501","message":"permission denied for relation limited_article_stars"}|] + , matchStatus = 401 + , matchHeaders = [] + } describe "CSV insert" $ do @@ -237,11 +289,23 @@ "Location" <:> "/no_pk?a=is.null&b=eq.foo"] } + it "only returns the requested column header with its associated data" $ + request methodPost "/projects?select=id" + [("Content-Type", "text/csv"), ("Accept", "text/csv"), ("Prefer", "return=representation")] + "id,name,client_id\n8,Xenix,1\n9,Windows NT,1" + `shouldRespondWith` ResponseMatcher { + matchBody = Just "id\n8\n9" + , matchStatus = 201 + , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8", + "Content-Range" <:> "*/*"] + } context "with wrong number of columns" $ it "fails for too few" $ do p <- request methodPost "/no_pk" [("Content-Type", "text/csv")] "a,b\nfoo,bar\nbaz" - liftIO $ simpleStatus p `shouldBe` badRequest400 + liftIO $ do + simpleStatus p `shouldBe` badRequest400 + isErrorFormat (simpleBody p) `shouldBe` True context "with unicode values" $ it "succeeds and returns usable location header" $ do @@ -250,7 +314,7 @@ [("Prefer", "return=representation")] payload liftIO $ do - simpleBody p `shouldBe` payload + simpleBody p `shouldBe` "["<>payload<>"]" simpleStatus p `shouldBe` created201 let Just location = lookup hLocation $ simpleHeaders p @@ -258,81 +322,6 @@ liftIO $ simpleBody r `shouldBe` "["<>payload<>"]" - describe "Putting record" $ do - - context "to unknown uri" $ - it "gives a 404" $ do - pendingWith "Decide on PUT usefullness" - request methodPut "/fake" [] - [json| { "real": false } |] - `shouldRespondWith` 404 - - context "to a known uri" $ do - context "without a fully-specified primary key" $ - it "is not an allowed operation" $ do - pendingWith "Decide on PUT usefullness" - request methodPut "/compound_pk?k1=eq.12" [] - [json| { "k1":12, "k2":42 } |] - `shouldRespondWith` 405 - - context "with a fully-specified primary key" $ do - - context "not specifying every column in the table" $ - it "is rejected for lack of idempotence" $ do - pendingWith "Decide on PUT usefullness" - request methodPut "/compound_pk?k1=eq.12&k2=eq.42" [] - [json| { "k1":12, "k2":42 } |] - `shouldRespondWith` 400 - - context "specifying every column in the table" $ do - it "can create a new record" $ do - pendingWith "Decide on PUT usefullness" - p <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" [] - [json| { "k1":12, "k2":42, "extra":3 } |] - liftIO $ do - simpleBody p `shouldBe` "" - simpleStatus p `shouldBe` status204 - - r <- get "/compound_pk?k1=eq.12&k2=eq.42" - let rows = fromJust (JSON.decode $ simpleBody r :: Maybe [CompoundPK]) - liftIO $ do - length rows `shouldBe` 1 - let record = head rows - compoundK1 record `shouldBe` 12 - compoundK2 record `shouldBe` "42" - compoundExtra record `shouldBe` Just 3 - - it "can update an existing record" $ do - pendingWith "Decide on PUT usefullness" - _ <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" [] - [json| { "k1":12, "k2":42, "extra":4 } |] - _ <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" [] - [json| { "k1":12, "k2":42, "extra":5 } |] - - r <- get "/compound_pk?k1=eq.12&k2=eq.42" - let rows = fromJust (JSON.decode $ simpleBody r :: Maybe [CompoundPK]) - liftIO $ do - length rows `shouldBe` 1 - let record = head rows - compoundExtra record `shouldBe` Just 5 - - context "with an auto-incrementing primary key"$ - - it "succeeds with 204" $ do - pendingWith "Decide on PUT usefullness" - request methodPut "/auto_incrementing_pk?id=eq.1" [] - [json| { - "id":1, - "nullable_string":"hi", - "non_nullable_string":"bye", - "inserted_at": "2020-11-11" - } |] - `shouldRespondWith` ResponseMatcher { - matchBody = Nothing, - matchStatus = 204, - matchHeaders = [] - } - describe "Patching record" $ do context "to unknown uri" $ @@ -345,26 +334,50 @@ it "indicates no records found to update" $ request methodPatch "/empty_table" [] [json| { "extra":20 } |] - `shouldRespondWith` 404 + `shouldRespondWith` ResponseMatcher { + matchBody = Just "", + matchStatus = 204, + matchHeaders = ["Content-Range" <:> "*/*"] + } context "in a nonempty table" $ do it "can update a single item" $ do g <- get "/items?id=eq.42" liftIO $ simpleHeaders g - `shouldSatisfy` matchHeader "Content-Range" "\\*/0" + `shouldSatisfy` matchHeader "Content-Range" "\\*/\\*" p <- request methodPatch "/items?id=eq.2" [] [json| { "id":42 } |] pure p `shouldRespondWith` ResponseMatcher { matchBody = Nothing, matchStatus = 204, - matchHeaders = ["Content-Range" <:> "0-0/1"] + matchHeaders = ["Content-Range" <:> "0-0/*"] } - liftIO $ - lookup hContentType (simpleHeaders p) `shouldBe` Nothing + liftIO $ lookup hContentType (simpleHeaders p) `shouldBe` Nothing + -- check it really got updated g' <- get "/items?id=eq.42" liftIO $ simpleHeaders g' - `shouldSatisfy` matchHeader "Content-Range" "0-0/1" + `shouldSatisfy` matchHeader "Content-Range" "0-0/\\*" + -- put value back for other tests + void $ request methodPatch "/items?id=eq.42" [] [json| { "id":2 } |] + it "returns empty array when no rows updated and return=rep" $ + request methodPatch "/items?id=eq.999999" + [("Prefer", "return=representation")] [json| { "id":999999 } |] + `shouldRespondWith` ResponseMatcher { + matchBody = Just "[]", + matchStatus = 200, + matchHeaders = ["Content-Range" <:> "*/*"] + } + + it "returns updated object as array when return=rep" $ + request methodPatch "/items?id=eq.2" + [("Prefer", "return=representation")] [json| { "id":2 } |] + `shouldRespondWith` ResponseMatcher { + matchBody = Just [str|[{"id":2}]|], + matchStatus = 200, + matchHeaders = ["Content-Range" <:> "0-0/*"] + } + it "can update multiple items" $ do replicateM_ 10 $ post "/auto_incrementing_pk" [json| { non_nullable_string: "a" } |] @@ -375,7 +388,7 @@ [json| { non_nullable_string: "c" } |] g <- get "/auto_incrementing_pk?non_nullable_string=eq.c" liftIO $ simpleHeaders g - `shouldSatisfy` matchHeader "Content-Range" "0-9/10" + `shouldSatisfy` matchHeader "Content-Range" "0-9/\\*" it "can set a column to NULL" $ do _ <- post "/no_pk" [json| { a: "keepme", b: "nullme" } |] @@ -383,12 +396,28 @@ get "/no_pk?a=eq.keepme" `shouldRespondWith` [json| [{ a: "keepme", b: null }] |] + it "can set a json column to escaped value" $ do + _ <- post "/json" [json| { data: {"escaped":"bar"} } |] + request methodPatch "/json?data->>escaped=eq.bar" + [("Prefer", "return=representation")] + [json| { "data": { "escaped":" \"bar" } } |] + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| [{ "data": { "escaped":" \"bar" } }] |] + , matchStatus = 200 + , matchHeaders = [] + } + it "can update based on a computed column" $ request methodPatch "/items?always_true=eq.false" [("Prefer", "return=representation")] [json| { id: 100 } |] - `shouldRespondWith` 404 + `shouldRespondWith` ResponseMatcher { + matchBody = Just "[]", + matchStatus = 200, + matchHeaders = ["Content-Range" <:> "*/*"] + } + it "can provide a representation" $ do _ <- post "/items" [json| { id: 1 } |] @@ -398,17 +427,6 @@ [json| { id: 99 } |] `shouldRespondWith` [json| [{id:99}] |] - it "can set a json column to escaped value" $ do - _ <- post "/json" [json| { data: {"escaped":"bar"} } |] - request methodPatch "/json?data->>escaped=eq.bar" - [("Prefer", "return=representation")] - [json| { "data": { "escaped":" \"bar" } } |] - `shouldRespondWith` ResponseMatcher { - matchBody = Just [json| [{ "data": { "escaped":" \"bar" } }] |] - , matchStatus = 200 - , matchHeaders = [] - } - context "with unicode values" $ it "succeeds and returns values intact" $ do void $ request methodPost "/no_pk" [] @@ -430,13 +448,13 @@ [ auth, ("Prefer", "return=representation") ] [json| { "secret": "nyancat" } |] liftIO $ do - simpleBody p1 `shouldBe` [str|{"owner":"jdoe","secret":"nyancat"}|] - simpleStatus p1 `shouldBe` created201 + simpleBody p1 `shouldBe` [str|[{"owner":"jdoe","secret":"nyancat"}]|] + simpleStatus p1 `shouldBe` created201 p2 <- request methodPost "/authors_only" -- jwt token for jroe [ authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqcm9lIn0.YuF_VfmyIxWyuceT7crnNKEprIYXsJAyXid3rjPjIow", ("Prefer", "return=representation") ] [json| { "secret": "lolcat", "owner": "hacker" } |] liftIO $ do - simpleBody p2 `shouldBe` [str|{"owner":"jroe","secret":"lolcat"}|] - simpleStatus p2 `shouldBe` created201 + simpleBody p2 `shouldBe` [str|[{"owner":"jroe","secret":"lolcat"}]|] + simpleStatus p2 `shouldBe` created201 diff --git a/test/Feature/NoJwtSpec.hs b/test/Feature/NoJwtSpec.hs new file mode 100644 --- /dev/null +++ b/test/Feature/NoJwtSpec.hs @@ -0,0 +1,25 @@ +module Feature.NoJwtSpec where + +-- {{{ Imports +import Test.Hspec +import Test.Hspec.Wai +import Network.HTTP.Types + +import SpecHelper +import Network.Wai (Application) + +import Protolude hiding (get) +-- }}} + +spec :: SpecWith Application +spec = describe "server started without JWT secret" $ do + + -- this test will stop working 9999999999s after the UNIX EPOCH + it "responds with error on attempted auth" $ do + let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjk5OTk5OTk5OTksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.QaPPLWTuyydMu_q7H4noMT7Lk6P4muet1OpJXF6ofhc" + request methodGet "/authors_only" [auth] "" + `shouldRespondWith` 500 + + it "behaves normally when user does not attempt auth" $ + request methodGet "/items" [] "" + `shouldRespondWith` 200 diff --git a/test/Feature/ProxySpec.hs b/test/Feature/ProxySpec.hs new file mode 100644 --- /dev/null +++ b/test/Feature/ProxySpec.hs @@ -0,0 +1,15 @@ +module Feature.ProxySpec where + +import Test.Hspec hiding (pendingWith) + +import SpecHelper + +import Network.Wai (Application) + +import Protolude hiding (get) + +spec :: SpecWith Application +spec = + describe "GET / with proxy" $ + it "returns a valid openapi spec with proxy" $ + validateOpenApiResponse [("Accept", "application/openapi+json")] diff --git a/test/Feature/QueryLimitedSpec.hs b/test/Feature/QueryLimitedSpec.hs --- a/test/Feature/QueryLimitedSpec.hs +++ b/test/Feature/QueryLimitedSpec.hs @@ -9,6 +9,8 @@ import SpecHelper import Network.Wai (Application) +import Protolude hiding (get) + spec :: SpecWith Application spec = describe "Requesting many items with server limits enabled" $ do @@ -16,8 +18,8 @@ get "/items" `shouldRespondWith` ResponseMatcher { matchBody = Just [json| [{"id":1},{"id":2}] |] - , matchStatus = 206 - , matchHeaders = ["Content-Range" <:> "0-1/15"] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-1/*"] } it "respects additional client limiting" $ do @@ -25,13 +27,22 @@ (rangeHdrs $ ByteRangeFromTo 0 0) "" liftIO $ do simpleHeaders r `shouldSatisfy` - matchHeader "Content-Range" "0-0/15" - simpleStatus r `shouldBe` partialContent206 + matchHeader "Content-Range" "0-0/*" + simpleStatus r `shouldBe` ok200 it "limit works on all levels" $ get "/users?select=id,tasks{id}&order=id.asc&tasks.order=id.asc" `shouldRespondWith` ResponseMatcher { matchBody = Just [str|[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":5},{"id":6}]}]|] - , matchStatus = 206 - , matchHeaders = ["Content-Range" <:> "0-1/3"] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-1/*"] } + + it "limit is not applied to parent embeds" $ + get "/tasks?select=id,project{id}&id=gt.5" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [str|[{"id":6,"project":{"id":3}},{"id":7,"project":{"id":4}}]|] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-1/*"] + } + diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs --- a/test/Feature/QuerySpec.hs +++ b/test/Feature/QuerySpec.hs @@ -4,12 +4,14 @@ import Test.Hspec.Wai import Test.Hspec.Wai.JSON import Network.HTTP.Types -import Network.Wai.Test (SResponse(simpleHeaders)) +import Network.Wai.Test (SResponse(simpleHeaders,simpleStatus,simpleBody)) import SpecHelper import Text.Heredoc import Network.Wai (Application) +import Protolude hiding (get) + spec :: SpecWith Application spec = do @@ -17,6 +19,10 @@ it "should not confuse count column with pg_catalog.count aggregate" $ get "/has_count_column" `shouldRespondWith` 200 + describe "Querying a table with a column called t" $ + it "should not conflict with internal postgrest table alias" $ + get "/clashing_column?select=t" `shouldRespondWith` 200 + describe "Querying a nonexistent table" $ it "causes a 404" $ get "/faketable" `shouldRespondWith` 404 @@ -27,7 +33,7 @@ `shouldRespondWith` ResponseMatcher { matchBody = Just [json| [{"id":5}] |] , matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-0/1"] + , matchHeaders = ["Content-Range" <:> "0-0/*"] } it "matches with equality using not operator" $ @@ -35,7 +41,7 @@ `shouldRespondWith` ResponseMatcher { matchBody = Just [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |] , matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-13/14"] + , matchHeaders = ["Content-Range" <:> "0-13/*"] } it "matches with more than one condition using not operator" $ @@ -46,13 +52,13 @@ `shouldRespondWith` ResponseMatcher { matchBody = Just [json| [{"id":14},{"id":15}] |] , matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-1/2"] + , matchHeaders = ["Content-Range" <:> "0-1/*"] } get "/items?id=not.gt.2&order=id.asc" `shouldRespondWith` ResponseMatcher { matchBody = Just [json| [{"id":1},{"id":2}] |] , matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-1/2"] + , matchHeaders = ["Content-Range" <:> "0-1/*"] } it "matches items IN" $ @@ -60,7 +66,7 @@ `shouldRespondWith` ResponseMatcher { matchBody = Just [json| [{"id":1},{"id":3},{"id":5}] |] , matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-2/3"] + , matchHeaders = ["Content-Range" <:> "0-2/*"] } it "matches items NOT IN" $ @@ -68,7 +74,7 @@ `shouldRespondWith` ResponseMatcher { matchBody = Just [json| [{"id":1},{"id":3},{"id":5}] |] , matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-2/3"] + , matchHeaders = ["Content-Range" <:> "0-2/*"] } it "matches items NOT IN using not operator" $ @@ -76,7 +82,7 @@ `shouldRespondWith` ResponseMatcher { matchBody = Just [json| [{"id":1},{"id":3},{"id":5}] |] , matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-2/3"] + , matchHeaders = ["Content-Range" <:> "0-2/*"] } it "matches nulls using not operator" $ @@ -126,6 +132,14 @@ get "/items?order=anti_id.desc" `shouldRespondWith` [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |] + it "matches filtering nested items 2" $ + get "/clients?select=id,projects{id,tasks2{id,name}}&projects.tasks.name=like.Design*" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| {"message":"could not find foreign keys between these entities, no relation between projects and tasks2"}|] + , matchStatus = 400 + , matchHeaders = [] + } + it "matches filtering nested items" $ get "/clients?select=id,projects{id,tasks{id,name}}&projects.tasks.name=like.Design*" `shouldRespondWith` [str|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1,"name":"Design w7"}]},{"id":2,"tasks":[{"id":3,"name":"Design w10"}]}]},{"id":2,"projects":[{"id":3,"tasks":[{"id":5,"name":"Design IOS"}]},{"id":4,"tasks":[{"id":7,"name":"Design OSX"}]}]}]|] @@ -225,7 +239,15 @@ get "/projects?id=eq.1&select=myId:id, name, project_client:client_id{*}, project_tasks:tasks{id, name}" `shouldRespondWith` [str|[{"myId":1,"name":"Windows 7","project_client":{"id":1,"name":"Microsoft"},"project_tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|] + it "requesting parents two levels up while using FK to specify the link" $ + get "/tasks?id=eq.1&select=id,name,project:project_id{id,name,client:client_id{id,name}}" `shouldRespondWith` + [str|[{"id":1,"name":"Design w7","project":{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}}]|] + it "requesting parents two levels up while using FK to specify the link (with rename)" $ + get "/tasks?id=eq.1&select=id,name,project:project_id{id,name,client:client_id{id,name}}" `shouldRespondWith` + [str|[{"id":1,"name":"Design w7","project":{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}}]|] + + it "requesting parents and filtering parent columns" $ get "/projects?id=eq.1&select=id, name, clients{id}" `shouldRespondWith` [str|[{"id":1,"name":"Windows 7","clients":{"id":1}}]|] @@ -259,6 +281,11 @@ get "/projects_view?id=eq.1&select=id, name, clients{*}, tasks{id, name}" `shouldRespondWith` [str|[{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|] + it "requesting parents and children on views with renamed keys" $ + get "/projects_view_alt?t_id=eq.1&select=t_id, name, clients{*}, tasks{id, name}" `shouldRespondWith` + [str|[{"t_id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|] + + it "requesting children with composite key" $ get "/users_tasks?user_id=eq.2&task_id=eq.6&select=*, comments{content}" `shouldRespondWith` [str|[{"user_id":2,"task_id":6,"comments":[{"content":"Needs to be delivered ASAP"}]}]|] @@ -275,60 +302,33 @@ get "/projects?id=in.1,3&select=id,name,client_id,client{id,name}" `shouldRespondWith` [str|[{"id":1,"name":"Windows 7","client_id":1,"client":{"id":1,"name":"Microsoft"}},{"id":3,"name":"IOS","client_id":2,"client":{"id":2,"name":"Apple"}}]|] - - describe "Plurality singular" $ do - it "will select an existing object" $ - request methodGet "/items?id=eq.5" [("Prefer","plurality=singular")] "" - `shouldRespondWith` ResponseMatcher { - matchBody = Just [json| {"id":5} |] - , matchStatus = 200 - , matchHeaders = [] - } - - it "can combine multiple prefer values" $ - request methodGet "/items?id=eq.5" [("Prefer","plurality=singular ; future=new; count=none")] "" - `shouldRespondWith` ResponseMatcher { - matchBody = Just [json| {"id":5} |] - , matchStatus = 200 - , matchHeaders = [] - } - - it "works in the presence of a range header" $ - let headers = ("Prefer","plurality=singular") : - rangeHdrs (ByteRangeFromTo 0 9) in - request methodGet "/items" headers "" - `shouldRespondWith` ResponseMatcher { - matchBody = Just [json| {"id":1} |] - , matchStatus = 200 - , matchHeaders = [] - } - - it "will respond with 404 when not found" $ - request methodGet "/items?id=eq.9999" [("Prefer","plurality=singular")] "" - `shouldRespondWith` 404 - - it "can shape plurality singular object routes" $ - request methodGet "/projects_view?id=eq.1&select=id,name,clients{*},tasks{id,name}" [("Prefer","plurality=singular")] "" - `shouldRespondWith` - [str|{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}|] - - describe "ordering response" $ do it "by a column asc" $ get "/items?id=lte.2&order=id.asc" `shouldRespondWith` ResponseMatcher { matchBody = Just [json| [{"id":1},{"id":2}] |] , matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-1/2"] + , matchHeaders = ["Content-Range" <:> "0-1/*"] } it "by a column desc" $ get "/items?id=lte.2&order=id.desc" `shouldRespondWith` ResponseMatcher { matchBody = Just [json| [{"id":2},{"id":1}] |] , matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-1/2"] + , matchHeaders = ["Content-Range" <:> "0-1/*"] } + it "by a column with nulls first" $ + get "/no_pk?order=a.nullsfirst" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| [{"a":null,"b":null}, + {"a":"1","b":"0"}, + {"a":"2","b":"0"} + ] |] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-2/*"] + } + it "by a column asc with nulls last" $ get "/no_pk?order=a.asc.nullslast" `shouldRespondWith` ResponseMatcher { @@ -336,7 +336,7 @@ {"a":"2","b":"0"}, {"a":null,"b":null}] |] , matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-2/3"] + , matchHeaders = ["Content-Range" <:> "0-2/*"] } it "by a column desc with nulls first" $ @@ -346,7 +346,7 @@ {"a":"2","b":"0"}, {"a":"1","b":"0"}] |] , matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-2/3"] + , matchHeaders = ["Content-Range" <:> "0-2/*"] } it "by a column desc with nulls last" $ @@ -356,9 +356,17 @@ {"a":"1","b":"0"}, {"a":null,"b":null}] |] , matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-2/3"] + , matchHeaders = ["Content-Range" <:> "0-2/*"] } + it "by a json column property asc" $ + get "/json?order=data->>id.asc" `shouldRespondWith` + [json| [{"data": {"id": 0}}, {"data": {"id": 1, "foo": {"bar": "baz"}}}, {"data": {"id": 3}}] |] + + it "by a json column with two level property nulls first" $ + get "/json?order=data->foo->>bar.nullsfirst" `shouldRespondWith` + [json| [{"data": {"id": 3}}, {"data": {"id": 0}}, {"data": {"id": 1, "foo": {"bar": "baz"}}}] |] + it "without other constraints" $ get "/items?order=id.asc" `shouldRespondWith` 200 @@ -395,6 +403,27 @@ (acceptHdrs "*/*") "" `shouldRespondWith` 200 + it "*/* should rescue an unknown type" $ + request methodGet "/simple_pk" + (acceptHdrs "text/unknowntype, */*") "" + `shouldRespondWith` 200 + + it "specific available preference should override */*" $ do + r <- request methodGet "/simple_pk" + (acceptHdrs "text/csv, */*") "" + liftIO $ do + let respHeaders = simpleHeaders r + respHeaders `shouldSatisfy` matchHeader + "Content-Type" "text/csv; charset=utf-8" + + it "honors client preference even when opposite of server preference" $ do + r <- request methodGet "/simple_pk" + (acceptHdrs "text/csv, application/json") "" + liftIO $ do + let respHeaders = simpleHeaders r + respHeaders `shouldSatisfy` matchHeader + "Content-Type" "text/csv; charset=utf-8" + it "should respond correctly to multiple types in accept header" $ request methodGet "/simple_pk" (acceptHdrs "text/unknowntype, text/csv") "" @@ -445,7 +474,17 @@ (rangeHdrs (ByteRangeFromTo 0 0)) [json| { "min": 2, "max": 4 } |] `shouldRespondWith` ResponseMatcher { matchBody = Just [json| [{"id":3}] |] - , matchStatus = 206 + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-0/*"] + } + + it "includes total count if requested" $ + request methodPost "/rpc/getitemrange" + (rangeHdrsWithCount (ByteRangeFromTo 0 0)) + [json| { "min": 2, "max": 4 } |] + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| [{"id":3}] |] + , matchStatus = 206 -- it now knows the response is partial , matchHeaders = ["Content-Range" <:> "0-0/2"] } @@ -454,6 +493,35 @@ post "/rpc/getitemrange" [json| { "min": 2, "max": 4 } |] `shouldRespondWith` [json| [ {"id": 3}, {"id":4} ] |] + context "unknown function" $ + it "returns 404" $ + post "/rpc/fakefunc" [json| {} |] `shouldRespondWith` 404 + + context "shaping the response returned by a proc" $ do + it "returns a project" $ + post "/rpc/getproject" [json| { "id": 1} |] `shouldRespondWith` + [str|[{"id":1,"name":"Windows 7","client_id":1}]|] + + it "can filter proc results" $ + post "/rpc/getallprojects?id=gt.1&id=lt.5&select=id" [json| {} |] `shouldRespondWith` + [json|[{"id":2},{"id":3},{"id":4}]|] + + it "can limit proc results" $ + post "/rpc/getallprojects?id=gt.1&id=lt.5&select=id?limit=2&offset=1" [json| {} |] + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json|[{"id":3},{"id":4}]|] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "1-2/*"] + } + + it "select works on the first level" $ + post "/rpc/getproject?select=id,name" [json| { "id": 1} |] `shouldRespondWith` + [str|[{"id":1,"name":"Windows 7"}]|] + + it "can embed foreign entities to the items returned by a proc" $ + post "/rpc/getproject?select=id,name,client{id},tasks{id}" [json| { "id": 1} |] `shouldRespondWith` + [str|[{"id":1,"name":"Windows 7","client":{"id":1},"tasks":[{"id":1},{"id":2}]}]|] + context "a proc that returns an empty rowset" $ it "returns empty json array" $ post "/rpc/test_empty_rowset" [json| {} |] `shouldRespondWith` @@ -462,21 +530,28 @@ context "a proc that returns plain text" $ do it "returns proper json" $ post "/rpc/sayhello" [json| { "name": "world" } |] `shouldRespondWith` - [json| [{"sayhello":"Hello, world"}] |] + [json|"Hello, world"|] it "can handle unicode" $ post "/rpc/sayhello" [json| { "name": "￥" } |] `shouldRespondWith` - [json| [{"sayhello":"Hello, ￥"}] |] + [json|"Hello, ￥"|] context "improper input" $ do it "rejects unknown content type even if payload is good" $ request methodPost "/rpc/sayhello" (acceptHdrs "audio/mpeg3") [json| { "name": "world" } |] `shouldRespondWith` 415 - it "rejects malformed json payload" $ - request methodPost "/rpc/sayhello" + it "rejects malformed json payload" $ do + p <- request methodPost "/rpc/sayhello" (acceptHdrs "application/json") "sdfsdf" - `shouldRespondWith` 400 + liftIO $ do + simpleStatus p `shouldBe` badRequest400 + isErrorFormat (simpleBody p) `shouldBe` True + it "treats simple plpgsql raise as invalid input" $ do + p <- post "/rpc/problem" "{}" + liftIO $ do + simpleStatus p `shouldBe` badRequest400 + isErrorFormat (simpleBody p) `shouldBe` True context "unsupported verbs" $ do it "DELETE fails" $ @@ -497,9 +572,23 @@ it "executes the proc exactly once per request" $ do post "/rpc/callcounter" [json| {} |] `shouldRespondWith` - [json| [{"callcounter":1}] |] + [json|1|] post "/rpc/callcounter" [json| {} |] `shouldRespondWith` - [json| [{"callcounter":2}] |] + [json|2|] + + context "expects a single json object" $ do + it "does not expand posted json into parameters" $ + request methodPost "/rpc/singlejsonparam" + [("Prefer","params=single-object")] [json| { "p1": 1, "p2": "text", "p3" : {"obj":"text"} } |] `shouldRespondWith` + [json| { "p1": 1, "p2": "text", "p3" : {"obj":"text"} } |] + + it "accepts parameters from an html form" $ + request methodPost "/rpc/singlejsonparam" + [("Prefer","params=single-object"),("Content-Type", "application/x-www-form-urlencoded")] + ("integer=7&double=2.71828&varchar=forms+are+fun&" <> + "boolean=false&date=1900-01-01&money=$3.99&enum=foo") `shouldRespondWith` + [json| { "integer": "7", "double": "2.71828", "varchar" : "forms are fun" + , "boolean":"false", "date":"1900-01-01", "money":"$3.99", "enum":"foo" } |] describe "weird requests" $ do it "can query as normal" $ do diff --git a/test/Feature/RangeSpec.hs b/test/Feature/RangeSpec.hs --- a/test/Feature/RangeSpec.hs +++ b/test/Feature/RangeSpec.hs @@ -12,6 +12,8 @@ import Text.Heredoc import Network.Wai (Application) +import Protolude hiding (get) + defaultRange :: BL.ByteString defaultRange = [json| { "min": 0, "max": 15 } |] @@ -28,8 +30,7 @@ context "when I don't want the count" $ do it "returns range Content-Range with */* for empty range" $ - request methodPost "/rpc/getitemrange" - [("Prefer", "count=none")] emptyRange + request methodPost "/rpc/getitemrange" [] emptyRange `shouldRespondWith` ResponseMatcher { matchBody = Just [json| [] |] , matchStatus = 200 @@ -37,8 +38,7 @@ } it "returns range Content-Range with range/*" $ - request methodPost "/rpc/getitemrange" - [("Prefer", "count=none")] defaultRange + request methodPost "/rpc/getitemrange" [] defaultRange `shouldRespondWith` ResponseMatcher { matchBody = Just [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |] , matchStatus = 200 @@ -53,8 +53,8 @@ (rangeHdrs $ ByteRangeFromTo 0 1) defaultRange liftIO $ do simpleHeaders r `shouldSatisfy` - matchHeader "Content-Range" "0-1/15" - simpleStatus r `shouldBe` partialContent206 + matchHeader "Content-Range" "0-1/*" + simpleStatus r `shouldBe` ok200 it "understands open-ended ranges" $ request methodPost "/rpc/getitemrange" @@ -67,7 +67,7 @@ `shouldRespondWith` ResponseMatcher { matchBody = Just "[]" , matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "*/0"] + , matchHeaders = ["Content-Range" <:> "*/*"] } it "allows one-item requests" $ do @@ -75,16 +75,16 @@ (rangeHdrs $ ByteRangeFromTo 0 0) defaultRange liftIO $ do simpleHeaders r `shouldSatisfy` - matchHeader "Content-Range" "0-0/15" - simpleStatus r `shouldBe` partialContent206 + matchHeader "Content-Range" "0-0/*" + simpleStatus r `shouldBe` ok200 it "handles ranges beyond collection length via truncation" $ do r <- request methodPost "/rpc/getitemrange" (rangeHdrs $ ByteRangeFromTo 10 100) defaultRange liftIO $ do simpleHeaders r `shouldSatisfy` - matchHeader "Content-Range" "10-14/15" - simpleStatus r `shouldBe` partialContent206 + matchHeader "Content-Range" "10-14/*" + simpleStatus r `shouldBe` ok200 context "of invalid range" $ do it "fails with 416 for offside range" $ @@ -94,7 +94,7 @@ it "refuses a range with nonzero start when there are no items" $ request methodPost "/rpc/getitemrange" - (rangeHdrs $ ByteRangeFromTo 1 2) emptyRange + (rangeHdrsWithCount $ ByteRangeFromTo 1 2) emptyRange `shouldRespondWith` ResponseMatcher { matchBody = Nothing , matchStatus = 416 @@ -103,12 +103,13 @@ it "refuses a range requesting start past last item" $ request methodPost "/rpc/getitemrange" - (rangeHdrs $ ByteRangeFromTo 100 199) defaultRange + (rangeHdrsWithCount $ ByteRangeFromTo 100 199) defaultRange `shouldRespondWith` ResponseMatcher { matchBody = Nothing , matchStatus = 416 , matchHeaders = ["Content-Range" <:> "*/15"] } + describe "GET /items" $ do context "without range headers" $ do context "with response under server size limit" $ @@ -149,42 +150,39 @@ `shouldRespondWith` ResponseMatcher { matchBody = Just [str|[{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}]|] , matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-14/15"] + , matchHeaders = ["Content-Range" <:> "0-14/*"] } it "top level limit with parameter" $ get "/items?select=id&order=id.asc&limit=3" `shouldRespondWith` ResponseMatcher { matchBody = Just [str|[{"id":1},{"id":2},{"id":3}]|] - , matchStatus = 206 - , matchHeaders = ["Content-Range" <:> "0-2/15"] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-2/*"] } it "headers override get parameters" $ request methodGet "/items?select=id&order=id.asc&limit=3" (rangeHdrs $ ByteRangeFromTo 0 1) "" `shouldRespondWith` ResponseMatcher { matchBody = Just [str|[{"id":1},{"id":2}]|] - , matchStatus = 206 - , matchHeaders = ["Content-Range" <:> "0-1/15"] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-1/*"] } it "limit works on all levels" $ - get "/clients?select=id,projects{id,tasks{id}}&order=id.asc&limit=1&projects.order=id.asc&projects.limit=1&projects.tasks.order=id.asc&projects.tasks.limit=2" + get "/clients?select=id,projects{id,tasks{id}}&order=id.asc&limit=1&projects.order=id.asc&projects.limit=2&projects.tasks.order=id.asc&projects.tasks.limit=1" `shouldRespondWith` ResponseMatcher { - matchBody = Just [str|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1},{"id":2}]}]}]|] - , matchStatus = 206 - , matchHeaders = ["Content-Range" <:> "0-0/2"] + matchBody = Just [str|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1}]},{"id":2,"tasks":[{"id":3}]}]}]|] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-0/*"] } - it "fails on offset specified below level 1" $ - get "/clients?select=id,projects{id,tasks{id}}&projects.offset=2&projects.limit=1" - `shouldRespondWith` 400 it "limit and offset works on first level" $ get "/items?select=id&order=id.asc&limit=3&offset=2" `shouldRespondWith` ResponseMatcher { matchBody = Just [str|[{"id":3},{"id":4},{"id":5}]|] - , matchStatus = 206 - , matchHeaders = ["Content-Range" <:> "2-4/15"] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "2-4/*"] } context "with range headers" $ do @@ -195,8 +193,8 @@ (rangeHdrs $ ByteRangeFromTo 0 1) "" liftIO $ do simpleHeaders r `shouldSatisfy` - matchHeader "Content-Range" "0-1/15" - simpleStatus r `shouldBe` partialContent206 + matchHeader "Content-Range" "0-1/*" + simpleStatus r `shouldBe` ok200 it "understands open-ended ranges" $ request methodGet "/items" @@ -209,7 +207,7 @@ `shouldRespondWith` ResponseMatcher { matchBody = Just "[]" , matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "*/0"] + , matchHeaders = ["Content-Range" <:> "*/*"] } it "allows one-item requests" $ do @@ -217,16 +215,16 @@ (rangeHdrs $ ByteRangeFromTo 0 0) "" liftIO $ do simpleHeaders r `shouldSatisfy` - matchHeader "Content-Range" "0-0/15" - simpleStatus r `shouldBe` partialContent206 + matchHeader "Content-Range" "0-0/*" + simpleStatus r `shouldBe` ok200 it "handles ranges beyond collection length via truncation" $ do r <- request methodGet "/items" (rangeHdrs $ ByteRangeFromTo 10 100) "" liftIO $ do simpleHeaders r `shouldSatisfy` - matchHeader "Content-Range" "10-14/15" - simpleStatus r `shouldBe` partialContent206 + matchHeader "Content-Range" "10-14/*" + simpleStatus r `shouldBe` ok200 context "of invalid range" $ do it "fails with 416 for offside range" $ @@ -236,7 +234,7 @@ it "refuses a range with nonzero start when there are no items" $ request methodGet "/menagerie" - (rangeHdrs $ ByteRangeFromTo 1 2) "" + (rangeHdrsWithCount $ ByteRangeFromTo 1 2) "" `shouldRespondWith` ResponseMatcher { matchBody = Nothing , matchStatus = 416 @@ -245,7 +243,7 @@ it "refuses a range requesting start past last item" $ request methodGet "/items" - (rangeHdrs $ ByteRangeFromTo 100 199) "" + (rangeHdrsWithCount $ ByteRangeFromTo 100 199) "" `shouldRespondWith` ResponseMatcher { matchBody = Nothing , matchStatus = 416 diff --git a/test/Feature/SingularSpec.hs b/test/Feature/SingularSpec.hs new file mode 100644 --- /dev/null +++ b/test/Feature/SingularSpec.hs @@ -0,0 +1,198 @@ +module Feature.SingularSpec where + +import Text.Heredoc +import Test.Hspec +import Test.Hspec.Wai +import Test.Hspec.Wai.JSON +import Network.HTTP.Types +import Network.Wai.Test (SResponse(..)) + +import Network.Wai (Application) + +import SpecHelper +import Protolude hiding (get) + + +spec :: SpecWith Application +spec = + describe "Requesting singular json object" $ do + let pgrstObj = "application/vnd.pgrst.object+json" + singular = ("Accept", pgrstObj) + + context "with GET request" $ do + it "fails for zero rows" $ + request methodGet "/items?id=gt.0&id=lt.0" [singular] "" + `shouldRespondWith` 406 + + it "will select an existing object" $ do + request methodGet "/items?id=eq.5" [singular] "" + `shouldRespondWith` [str|{"id":5}|] + -- also test without the +json suffix + request methodGet "/items?id=eq.5" + [("Accept", "application/vnd.pgrst.object")] "" + `shouldRespondWith` [str|{"id":5}|] + + it "can combine multiple prefer values" $ + request methodGet "/items?id=eq.5" [singular, ("Prefer","count=none")] "" + `shouldRespondWith` [str|{"id":5}|] + + it "can shape plurality singular object routes" $ + request methodGet "/projects_view?id=eq.1&select=id,name,clients{*},tasks{id,name}" [singular] "" + `shouldRespondWith` + [str|{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}|] + + context "when updating rows" $ do + + it "works for one row" $ do + _ <- post "/addresses" [json| { id: 97, address: "A Street" } |] + request methodPatch + "/addresses?id=eq.97" + [("Prefer", "return=representation"), singular] + [json| { address: "B Street" } |] + `shouldRespondWith` + [str|{"id":97,"address":"B Street"}|] + + it "raises an error for multiple rows" $ do + _ <- post "/addresses" [json| { id: 98, address: "xxx" } |] + _ <- post "/addresses" [json| { id: 99, address: "yyy" } |] + p <- request methodPatch + "/addresses?id=gt.0" + [("Prefer", "return=representation"), singular] + [json| { address: "zzz" } |] + liftIO $ do + simpleStatus p `shouldBe` notAcceptable406 + isErrorFormat (simpleBody p) `shouldBe` True + + -- the rows should not be updated, either + get "/addresses?id=eq.98" `shouldRespondWith` [str|[{"id":98,"address":"xxx"}]|] + + it "raises an error for zero rows" $ do + p <- request methodPatch "/items?id=gt.0&id=lt.0" + [("Prefer", "return=representation"), singular] [json|{"id":1}|] + liftIO $ do + simpleStatus p `shouldBe` notAcceptable406 + isErrorFormat (simpleBody p) `shouldBe` True + + context "when creating rows" $ do + + it "works for one row" $ do + p <- request methodPost + "/addresses" + [("Prefer", "return=representation"), singular] + [json| [ { id: 100, address: "xxx" } ] |] + liftIO $ simpleBody p `shouldBe` [str|{"id":100,"address":"xxx"}|] + + it "works for one row even with return=minimal" $ do + request methodPost "/addresses" + [("Prefer", "return=minimal"), singular] + [json| [ { id: 101, address: "xxx" } ] |] + `shouldRespondWith` ResponseMatcher { + matchBody = Just "" + , matchStatus = 201 + , matchHeaders = ["Content-Range" <:> "*/*"] + } + -- and the element should exist + get "/addresses?id=eq.101" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [str|[{"id":101,"address":"xxx"}]|] + , matchStatus = 200 + , matchHeaders = [] + } + + it "raises an error when attempting to create multiple entities" $ do + p <- request methodPost + "/addresses" + [("Prefer", "return=representation"), singular] + [json| [ { id: 200, address: "xxx" }, { id: 201, address: "yyy" } ] |] + liftIO $ simpleStatus p `shouldBe` notAcceptable406 + + -- the rows should not exist, either + get "/addresses?id=eq.200" `shouldRespondWith` "[]" + + it "return=minimal allows request to create multiple elements" $ + request methodPost "/addresses" + [("Prefer", "return=minimal"), singular] + [json| [ { id: 200, address: "xxx" }, { id: 201, address: "yyy" } ] |] + `shouldRespondWith` ResponseMatcher { + matchBody = Just "" + , matchStatus = 201 + , matchHeaders = ["Content-Range" <:> "*/*"] + } + + it "raises an error when creating zero entities" $ do + p <- request methodPost + "/addresses" + [("Prefer", "return=representation"), singular] + [json| [ ] |] + liftIO $ do + simpleStatus p `shouldBe` notAcceptable406 + isErrorFormat (simpleBody p) `shouldBe` True + + context "when deleting rows" $ do + + it "works for one row" $ do + p <- request methodDelete + "/items?id=eq.11" + [("Prefer", "return=representation"), singular] "" + liftIO $ simpleBody p `shouldBe` [str|{"id":11}|] + + it "raises an error when attempting to delete multiple entities" $ do + let firstItems = "/items?id=gt.0&id=lt.11" + request methodDelete firstItems + [("Prefer", "return=representation"), singular] "" + `shouldRespondWith` 406 + + -- the rows should not exist, either + get firstItems + `shouldRespondWith` ResponseMatcher { + matchBody = Nothing + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-9/*"] + } + + it "raises an error when deleting zero entities" $ do + p <- request methodDelete "/items?id=lt.0" + [("Prefer", "return=representation"), singular] "" + liftIO $ do + simpleStatus p `shouldBe` notAcceptable406 + isErrorFormat (simpleBody p) `shouldBe` True + + context "when calling a stored proc" $ do + + it "fails for zero rows" $ do + p <- request methodPost "/rpc/getproject" + [singular] [json|{ "id": 9999999}|] + liftIO $ do + simpleStatus p `shouldBe` notAcceptable406 + isErrorFormat (simpleBody p) `shouldBe` True + + -- this one may be controversial, should vnd.pgrst.object include + -- the likes of 2 and "hello?" + it "succeeds for scalar result" $ + request methodPost "/rpc/sayhello" + [singular] [json|{ "name": "world"}|] + `shouldRespondWith` 200 + + it "returns a single object for json proc" $ + request methodPost "/rpc/getproject" + [singular] [json|{ "id": 1}|] `shouldRespondWith` + [str|{"id":1,"name":"Windows 7","client_id":1}|] + + it "fails for multiple rows" $ do + p <- request methodPost "/rpc/getallprojects" [singular] "{}" + liftIO $ do + simpleStatus p `shouldBe` notAcceptable406 + isErrorFormat (simpleBody p) `shouldBe` True + + it "executes the proc exactly once per request" $ do + request methodPost "/rpc/getproject?select=id,name" [] [json| {"id": 1} |] + `shouldRespondWith` [str|[{"id":1,"name":"Windows 7"}]|] + p <- request methodPost "/rpc/setprojects" [singular] + [json| {"id_l": 1, "id_h": 2, "name": "changed"} |] + liftIO $ do + simpleStatus p `shouldBe` notAcceptable406 + isErrorFormat (simpleBody p) `shouldBe` True + + -- should not actually have executed the function + request methodPost "/rpc/getproject?select=id,name" [] [json| {"id": 1} |] + `shouldRespondWith` [str|[{"id":1,"name":"Windows 7"}]|] diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs --- a/test/Feature/StructureSpec.hs +++ b/test/Feature/StructureSpec.hs @@ -2,387 +2,87 @@ import Test.Hspec hiding (pendingWith) import Test.Hspec.Wai -import Test.Hspec.Wai.JSON +import Network.HTTP.Types +import Control.Lens ((^?)) +import Data.Aeson.Lens +import Data.Aeson.QQ + import SpecHelper -import Network.HTTP.Types import Network.Wai (Application) -import Network.Wai.Test (SResponse(simpleHeaders)) +import Network.Wai.Test (SResponse(..)) +import Protolude hiding (get) + spec :: SpecWith Application spec = do - describe "GET /" $ do - it "lists views in schema" $ - request methodGet "/" [] "" - `shouldRespondWith` [json| [ - {"schema":"test","name":"Escap3e;","insertable":true} - , {"schema":"test","name":"addresses","insertable":true} - , {"schema":"test","name":"articleStars","insertable":true} - , {"schema":"test","name":"articles","insertable":true} - , {"schema":"test","name":"auto_incrementing_pk","insertable":true} - , {"schema":"test","name":"clients","insertable":true} - , {"schema":"test","name":"comments","insertable":true} - , {"schema":"test","name":"complex_items","insertable":true} - , {"schema":"test","name":"compound_pk","insertable":true} - , {"schema":"test","name":"empty_table","insertable":true} - , {"schema":"test","name":"filtered_tasks","insertable":true} - , {"schema":"test","name":"ghostBusters","insertable":true} - , {"schema":"test","name":"has_count_column","insertable":false} - , {"schema":"test","name":"has_fk","insertable":true} - , {"schema":"test","name":"insertable_view_with_join","insertable":true} - , {"schema":"test","name":"insertonly","insertable":true} - , {"schema":"test","name":"items","insertable":true} - , {"schema":"test","name":"json","insertable":true} - , {"schema":"test","name":"materialized_view","insertable":false} - , {"schema":"test","name":"menagerie","insertable":true} - , {"schema":"test","name":"no_pk","insertable":true} - , {"schema":"test","name":"nullable_integer","insertable":true} - , {"schema":"test","name":"orders","insertable":true} - , {"schema":"test","name":"projects","insertable":true} - , {"schema":"test","name":"projects_view","insertable":true} - , {"schema":"test","name":"simple_pk","insertable":true} - , {"schema":"test","name":"tasks","insertable":true} - , {"schema":"test","name":"tsearch","insertable":true} - , {"schema":"test","name":"users","insertable":true} - , {"schema":"test","name":"users_projects","insertable":true} - , {"schema":"test","name":"users_tasks","insertable":true} - , {"schema":"test","name":"withUnique","insertable":true} - ] |] - {matchStatus = 200} - - it "lists only views user has permission to see" $ do - let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0" - - request methodGet "/" [auth] "" - `shouldRespondWith` [json| [ - {"schema":"test","name":"authors_only","insertable":true} - ] |] - {matchStatus = 200} - - describe "Table info" $ do - it "The structure of complex views is correctly detected" $ - request methodOptions "/filtered_tasks" [] "" `shouldRespondWith` - [json| - { - "pkey": [ - "myId" - ], - "columns": [ - { - "references": null, - "default": null, - "precision": 32, - "updatable": true, - "schema": "test", - "name": "myId", - "type": "integer", - "maxLen": null, - "enum": [], - "nullable": true, - "position": 1 - }, - { - "references": null, - "default": null, - "precision": null, - "updatable": true, - "schema": "test", - "name": "name", - "type": "text", - "maxLen": null, - "enum": [], - "nullable": true, - "position": 2 - }, - { - "references": { - "schema": "test", - "column": "id", - "table": "projects" - }, - "default": null, - "precision": 32, - "updatable": true, - "schema": "test", - "name": "projectID", - "type": "integer", - "maxLen": null, - "enum": [], - "nullable": true, - "position": 3 - } - ] - } - |] + describe "OpenAPI" $ do + it "root path returns a valid openapi spec" $ + validateOpenApiResponse [("Accept", "application/openapi+json")] - it "is available with OPTIONS verb" $ - request methodOptions "/menagerie" [] "" `shouldRespondWith` - [json| - { - "pkey":["integer"], - "columns":[ - { - "default": null, - "precision": 32, - "updatable": true, - "schema": "test", - "name": "integer", - "type": "integer", - "maxLen": null, - "enum": [], - "nullable": false, - "position": 1, - "references": null, - "default": null - }, { - "default": null, - "precision": 53, - "updatable": true, - "schema": "test", - "name": "double", - "type": "double precision", - "maxLen": null, - "enum": [], - "nullable": false, - "references": null, - "position": 2 - }, { - "default": null, - "precision": null, - "updatable": true, - "schema": "test", - "name": "varchar", - "type": "character varying", - "maxLen": null, - "enum": [], - "nullable": false, - "position": 3, - "references": null, - "default": null - }, { - "default": null, - "precision": null, - "updatable": true, - "schema": "test", - "name": "boolean", - "type": "boolean", - "maxLen": null, - "enum": [], - "nullable": false, - "references": null, - "position": 4 - }, { - "default": null, - "precision": null, - "updatable": true, - "schema": "test", - "name": "date", - "type": "date", - "maxLen": null, - "enum": [], - "nullable": false, - "references": null, - "position": 5 - }, { - "default": null, - "precision": null, - "updatable": true, - "schema": "test", - "name": "money", - "type": "money", - "maxLen": null, - "enum": [], - "nullable": false, - "position": 6, - "references": null, - "default": null - }, { - "default": null, - "precision": null, - "updatable": true, - "schema": "test", - "name": "enum", - "type": "USER-DEFINED", - "maxLen": null, - "enum": [ - "foo", - "bar" - ], - "nullable": false, - "position": 7, - "references": null, - "default": null - } - ] - } - |] + it "should respond to openapi request on none root path with 415" $ + request methodGet "/items" + (acceptHdrs "application/openapi+json") "" + `shouldRespondWith` 415 - it "it includes primary and foreign keys for views" $ - request methodOptions "/projects_view" [] "" `shouldRespondWith` - [json| - { - "pkey":[ - "id" - ], - "columns":[ - { - "references":null, - "default":null, - "precision":32, - "updatable":true, - "schema":"test", - "name":"id", - "type":"integer", - "maxLen":null, - "enum":[], - "nullable":true, - "position":1 - }, - { - "references":null, - "default":null, - "precision":null, - "updatable":true, - "schema":"test", - "name":"name", - "type":"text", - "maxLen":null, - "enum":[], - "nullable":true, - "position":2 - }, - { - "references": { - "schema":"test", - "column":"id", - "table":"clients" - }, - "default":null, - "precision":32, - "updatable":true, - "schema":"test", - "name":"client_id", - "type":"integer", - "maxLen":null, - "enum":[], - "nullable":true, - "position":3 - } - ] - } - |] + describe "RPC" $ - it "includes foreign key data" $ - request methodOptions "/has_fk" [] "" - `shouldRespondWith` [json| - { - "pkey": ["id"], - "columns":[ - { - "default": "nextval('test.has_fk_id_seq'::regclass)", - "precision": 64, - "updatable": true, - "schema": "test", - "name": "id", - "type": "bigint", - "maxLen": null, - "nullable": false, - "position": 1, - "enum": [], - "references": null - }, { - "default": null, - "precision": 32, - "updatable": true, - "schema": "test", - "name": "auto_inc_fk", - "type": "integer", - "maxLen": null, - "nullable": true, - "position": 2, - "enum": [], - "references": {"schema":"test", "table": "auto_incrementing_pk", "column": "id"} - }, { - "default": null, - "precision": null, - "updatable": true, - "schema": "test", - "name": "simple_fk", - "type": "character varying", - "maxLen": 255, - "nullable": true, - "position": 3, - "enum": [], - "references": {"schema":"test", "table": "simple_pk", "column": "k"} - } - ] - } - |] + it "includes a representative function with parameters" $ do + r <- simpleBody <$> get "/" + let ref = r ^? key "paths" . key "/rpc/varied_arguments" + . key "post" . key "parameters" + . nth 1 . key "schema" + . key "$ref" . _String + args = r ^? key "definitions" . key "(rpc) varied_arguments" - it "includes all information on views for renamed columns, and raises relations to correct schema" $ - request methodOptions "/articleStars" [] "" - `shouldRespondWith` [json| - { - "pkey": [ - "articleId", - "userId" - ], - "columns": [ - { - "references": { - "schema": "test", - "column": "id", - "table": "articles" - }, - "default": null, - "precision": 32, - "updatable": true, - "schema": "test", - "name": "articleId", - "type": "integer", - "maxLen": null, - "enum": [], - "nullable": true, - "position": 1 - }, + liftIO $ do + ref `shouldBe` Just "#/definitions/(rpc) varied_arguments" + args `shouldBe` Just + [aesonQQ| { - "references": { - "schema": "test", - "column": "id", - "table": "users" + "required": [ + "double", + "varchar", + "boolean", + "date", + "money", + "enum" + ], + "properties": { + "double": { + "format": "double precision", + "type": "string" + }, + "varchar": { + "format": "character varying", + "type": "string" + }, + "boolean": { + "format": "boolean", + "type": "boolean" + }, + "date": { + "format": "date", + "type": "string" + }, + "money": { + "format": "money", + "type": "string" + }, + "enum": { + "format": "test.enum_menagerie_type", + "type": "string" + }, + "integer": { + "format": "integer", + "type": "integer" + } }, - "default": null, - "precision": 32, - "updatable": true, - "schema": "test", - "name": "userId", - "type": "integer", - "maxLen": null, - "enum": [], - "nullable": true, - "position": 2 - }, - { - "references": null, - "default": null, - "precision": null, - "updatable": true, - "schema": "test", - "name": "createdAt", - "type": "timestamp without time zone", - "maxLen": null, - "enum": [], - "nullable": true, - "position": 3 + "type": "object" } - ] - } - |] - - it "errors for non existant tables" $ - request methodOptions "/dne" [] "" `shouldRespondWith` 404 + |] describe "Allow header" $ do diff --git a/test/Feature/UnicodeSpec.hs b/test/Feature/UnicodeSpec.hs --- a/test/Feature/UnicodeSpec.hs +++ b/test/Feature/UnicodeSpec.hs @@ -6,6 +6,8 @@ import Network.Wai (Application) import Control.Monad (void) +import Protolude hiding (get) + spec :: SpecWith Application spec = describe "Reading and writing to unicode schema and table names" $ diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -7,43 +7,72 @@ import PostgREST.DbStructure (getDbStructure) import PostgREST.App (postgrest) +import Control.AutoUpdate +import Data.Function (id) import Data.IORef -import Data.String.Conversions (cs) +import Data.Time.Clock.POSIX (getPOSIXTime) import qualified Feature.AuthSpec +import qualified Feature.BinaryJwtSecretSpec import qualified Feature.ConcurrentSpec import qualified Feature.CorsSpec import qualified Feature.DeleteSpec import qualified Feature.InsertSpec +import qualified Feature.NoJwtSpec import qualified Feature.QueryLimitedSpec import qualified Feature.QuerySpec import qualified Feature.RangeSpec import qualified Feature.StructureSpec +import qualified Feature.SingularSpec import qualified Feature.UnicodeSpec +import qualified Feature.ProxySpec +import Protolude + main :: IO () main = do - setupDb + testDbConn <- getEnvVarWithDefault "POSTGREST_TEST_CONNECTION" "postgres://postgrest_test@localhost/postgrest_test" + setupDb testDbConn - pool <- P.acquire (3, 10, cs testDbConn) + pool <- P.acquire (3, 10, toS testDbConn) + -- ask for the OS time at most once per second + getTime <- mkAutoUpdate + defaultUpdateSettings { updateAction = getPOSIXTime } + result <- P.use pool $ getDbStructure "test" - refDbStructure <- newIORef $ either (error.show) id result - let withApp = return $ postgrest testCfg refDbStructure pool - ltdApp = return $ postgrest testLtdRowsCfg refDbStructure pool - unicodeApp = return $ postgrest testUnicodeCfg refDbStructure pool + refDbStructure <- newIORef $ either (panic.show) id result + let withApp = return $ postgrest (testCfg testDbConn) refDbStructure pool getTime + ltdApp = return $ postgrest (testLtdRowsCfg testDbConn) refDbStructure pool getTime + unicodeApp = return $ postgrest (testUnicodeCfg testDbConn) refDbStructure pool getTime + proxyApp = return $ postgrest (testProxyCfg testDbConn) refDbStructure pool getTime + noJwtApp = return $ postgrest (testCfgNoJWT testDbConn) refDbStructure pool getTime + binaryJwtApp = return $ postgrest (testCfgBinaryJWT testDbConn) refDbStructure pool getTime + let reset = resetDb testDbConn hspec $ do - mapM_ (beforeAll_ resetDb . before withApp) specs + mapM_ (beforeAll_ reset . before withApp) specs -- this test runs with a different server flag - beforeAll_ resetDb . before ltdApp $ + beforeAll_ reset . before ltdApp $ describe "Feature.QueryLimitedSpec" Feature.QueryLimitedSpec.spec -- this test runs with a different schema - beforeAll_ resetDb . before unicodeApp $ + beforeAll_ reset . before unicodeApp $ describe "Feature.UnicodeSpec" Feature.UnicodeSpec.spec + -- this test runs with a proxy + beforeAll_ reset . before proxyApp $ + describe "Feature.ProxySpec" Feature.ProxySpec.spec + + -- this test runs without a JWT secret + beforeAll_ reset . before noJwtApp $ + describe "Feature.NoJwtSpec" Feature.NoJwtSpec.spec + + -- this test runs with a binary JWT secret + beforeAll_ reset . before binaryJwtApp $ + describe "Feature.BinaryJwtSecretSpec" Feature.BinaryJwtSecretSpec.spec + where specs = map (uncurry describe) [ ("Feature.AuthSpec" , Feature.AuthSpec.spec) @@ -53,5 +82,6 @@ , ("Feature.InsertSpec" , Feature.InsertSpec.spec) , ("Feature.QuerySpec" , Feature.QuerySpec.spec) , ("Feature.RangeSpec" , Feature.RangeSpec.spec) + , ("Feature.SingularSpec" , Feature.SingularSpec.spec) , ("Feature.StructureSpec" , Feature.StructureSpec.spec) ] diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -1,66 +1,140 @@ module SpecHelper where -import Data.String.Conversions (cs) import Control.Monad (void) -import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange, - hRange, hAuthorization, hAccept) -import Codec.Binary.Base64.String (encode) +import qualified System.IO.Error as E +import System.Environment (getEnv) + +import qualified Data.ByteString.Base64 as B64 (encode, decodeLenient) import Data.CaseInsensitive (CI(..)) +import qualified Data.Set as S +import qualified Data.Map.Strict as M +import Data.List (lookup) import Text.Regex.TDFA ((=~)) import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as BL import System.Process (readProcess) -import Web.JWT (secret) import PostgREST.Config (AppConfig(..)) -testDbConn :: String -testDbConn = "postgres://postgrest_test_authenticator@localhost:5432/postgrest_test" +import Test.Hspec hiding (pendingWith) +import Test.Hspec.Wai -testCfg :: AppConfig -testCfg = - AppConfig testDbConn "postgrest_test_anonymous" "test" 3000 (secret "safe") 10 Nothing True +import Network.HTTP.Types +import Network.Wai.Test (SResponse(simpleStatus, simpleHeaders, simpleBody)) -testUnicodeCfg :: AppConfig -testUnicodeCfg = - AppConfig testDbConn "postgrest_test_anonymous" "تست" 3000 (secret "safe") 10 Nothing True +import Data.Maybe (fromJust) +import Data.Aeson (decode, Value(..)) +import qualified Data.JsonSchema.Draft4 as D4 -testLtdRowsCfg :: AppConfig -testLtdRowsCfg = - AppConfig testDbConn "postgrest_test_anonymous" "test" 3000 (secret "safe") 10 (Just 2) True +import Protolude -setupDb :: IO () -setupDb = do - void $ readProcess "psql" ["-d", "postgres", "-a", "-f", "test/fixtures/database.sql"] [] - loadFixture "roles" - loadFixture "schema" - loadFixture "privileges" - resetDb +validateOpenApiResponse :: [Header] -> WaiSession () +validateOpenApiResponse headers = do + r <- request methodGet "/" headers "" + liftIO $ + let respStatus = simpleStatus r in + respStatus `shouldSatisfy` + \s -> s == Status { statusCode = 200, statusMessage="OK" } + liftIO $ + let respHeaders = simpleHeaders r in + respHeaders `shouldSatisfy` + \hs -> ("Content-Type", "application/openapi+json; charset=utf-8") `elem` hs + liftIO $ + let respBody = simpleBody r + schema :: D4.Schema + schema = D4.emptySchema { D4._schemaRef = Just "openapi.json" } + schemaContext :: D4.SchemaWithURI D4.Schema + schemaContext = D4.SchemaWithURI + { D4._swSchema = schema + , D4._swURI = Just "test/fixtures/openapi.json" + } + in + D4.fetchFilesystemAndValidate schemaContext ((fromJust . decode) respBody) `shouldReturn` Right () -resetDb :: IO () -resetDb = loadFixture "data" +getEnvVarWithDefault :: Text -> Text -> IO Text +getEnvVarWithDefault var def = do + varValue <- getEnv (toS var) `E.catchIOError` const (return $ toS def) + return $ toS varValue -loadFixture :: FilePath -> IO() -loadFixture name = - void $ readProcess "psql" ["-U", "postgrest_test", "-d", "postgrest_test", "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] [] +_baseCfg :: AppConfig +_baseCfg = -- Connection Settings + AppConfig mempty "postgrest_test_anonymous" Nothing "test" "localhost" 3000 + -- Jwt settings + (Just $ encodeUtf8 "safe") False + -- Connection Modifiers + 10 Nothing (Just "test.switch_role") + -- Debug Settings + True +testCfg :: Text -> AppConfig +testCfg testDbConn = _baseCfg { configDatabase = testDbConn } + +testCfgNoJWT :: Text -> AppConfig +testCfgNoJWT testDbConn = (testCfg testDbConn) { configJwtSecret = Nothing } + +testUnicodeCfg :: Text -> AppConfig +testUnicodeCfg testDbConn = (testCfg testDbConn) { configSchema = "تست" } + +testLtdRowsCfg :: Text -> AppConfig +testLtdRowsCfg testDbConn = (testCfg testDbConn) { configMaxRows = Just 2 } + +testProxyCfg :: Text -> AppConfig +testProxyCfg testDbConn = (testCfg testDbConn) { configProxyUri = Just "https://postgrest.com/openapi.json" } + +testCfgBinaryJWT :: Text -> AppConfig +testCfgBinaryJWT testDbConn = (testCfg testDbConn) { configJwtSecret = Just secretBs } + where secretBs = B64.decodeLenient "h2CGB1FoBd51aQooCS2g+UmRgYQfTPQ6v3+9ALbaqM4=" + + +setupDb :: Text -> IO () +setupDb dbConn = do + loadFixture dbConn "database" + loadFixture dbConn "roles" + loadFixture dbConn "schema" + loadFixture dbConn "jwt" + loadFixture dbConn "privileges" + resetDb dbConn + +resetDb :: Text -> IO () +resetDb dbConn = loadFixture dbConn "data" + +loadFixture :: Text -> FilePath -> IO() +loadFixture dbConn name = + void $ readProcess "psql" [toS dbConn, "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] [] + rangeHdrs :: ByteRange -> [Header] rangeHdrs r = [rangeUnit, (hRange, renderByteRange r)] +rangeHdrsWithCount :: ByteRange -> [Header] +rangeHdrsWithCount r = ("Prefer", "count=exact") : rangeHdrs r + acceptHdrs :: BS.ByteString -> [Header] acceptHdrs mime = [(hAccept, mime)] rangeUnit :: Header rangeUnit = ("Range-Unit" :: CI BS.ByteString, "items") -matchHeader :: CI BS.ByteString -> String -> [Header] -> Bool +matchHeader :: CI BS.ByteString -> BS.ByteString -> [Header] -> Bool matchHeader name valRegex headers = maybe False (=~ valRegex) $ lookup name headers -authHeaderBasic :: String -> String -> Header +authHeaderBasic :: BS.ByteString -> BS.ByteString -> Header authHeaderBasic u p = - (hAuthorization, cs $ "Basic " ++ encode (u ++ ":" ++ p)) + (hAuthorization, "Basic " <> (toS . B64.encode . toS $ u <> ":" <> p)) -authHeaderJWT :: String -> Header +authHeaderJWT :: BS.ByteString -> Header authHeaderJWT token = - (hAuthorization, cs $ "Bearer " ++ token) + (hAuthorization, "Bearer " <> token) + +-- | Tests whether the text can be parsed as a json object comtaining +-- the key "message", and optional keys "details", "hint", "code", +-- and no extraneous keys +isErrorFormat :: BL.ByteString -> Bool +isErrorFormat s = + "message" `S.member` keys && + S.null (S.difference keys validKeys) + where + obj = decode s :: Maybe (M.Map Text Value) + keys = fromMaybe S.empty (M.keysSet <$> obj) + validKeys = S.fromList ["message", "details", "hint", "code"] diff --git a/test/TestTypes.hs b/test/TestTypes.hs --- a/test/TestTypes.hs +++ b/test/TestTypes.hs @@ -1,23 +1,18 @@ module TestTypes ( IncPK(..) , CompoundPK(..) --- , incFromList --- , compoundFromList ) where import qualified Data.Aeson as JSON import Data.Aeson ((.:)) --- import Data.Maybe (fromJust) -import Control.Applicative -import Control.Monad (mzero) -import Prelude +import Protolude data IncPK = IncPK { incId :: Int -, incNullableStr :: Maybe String -, incStr :: String -, incInsert :: String +, incNullableStr :: Maybe Text +, incStr :: Text +, incInsert :: Text } deriving (Eq, Show) instance JSON.FromJSON IncPK where @@ -28,16 +23,9 @@ r .: "inserted_at" parseJSON _ = mzero --- incFromList :: [(String, SqlValue)] -> IncPK --- incFromList row = IncPK --- (fromSql . fromJust $ lookup "id" row) --- (fromSql . fromJust $ lookup "nullable_string" row) --- (fromSql . fromJust $ lookup "non_nullable_string" row) --- (fromSql . fromJust $ lookup "inserted_at" row) - data CompoundPK = CompoundPK { compoundK1 :: Int -, compoundK2 :: String +, compoundK2 :: Text , compoundExtra :: Maybe Int } deriving (Eq, Show) @@ -47,9 +35,3 @@ r .: "k2" <*> r .: "extra" parseJSON _ = mzero - --- compoundFromList :: [(String, SqlValue)] -> CompoundPK --- compoundFromList row = CompoundPK --- (fromSql . fromJust $ lookup "k1" row) --- (fromSql . fromJust $ lookup "k2" row) --- (fromSql . fromJust $ lookup "extra" row)